* Last processed by NICE on 05-Jan-1999 08:01:00 * Customized for : EEEI, HPUX, UNIX, MOTIF, F77 SUBROUTINE INPUT(SPEC,NSPEC,ERROR) C---------------------------------------------------------------------- C CLASS Internal routine C Close any input file, set the file specification for input, C open this file. C Arguments : C SPEC C*(*) File name including extension Input C NSPEC I Length of SPEC Input C ERROR L Logical error flag Output C---------------------------------------------------------------------- CHARACTER*(*) SPEC INTEGER LSIZE,NSPEC,LSIZE1 INTEGER*4 SAVED(32) LOGICAL ERROR, LSHARE INTEGER*4 MAX_RECORD PARAMETER (MAX_RECORD=2147483647) * INCLUDE 'inc:format.inc' INCLUDE 'common.inc' INCLUDE 'index.inc' INCLUDE 'convert.par' INTEGER LENC, LNAME, IER, I, ILUN0, OLUN0, LUN_1, LUN_2 $, SIC_GETLUN CHARACTER NAME*80, MESS*80, FILNAM*80, ACONV*20 LOGICAL TO_OLD SAVE LUN_1,LUN_2 * * Patch old file structure INTEGER*2 I_CODE,I_NEXT,I_LEX,I_NEX,I_XNEXT,I_EX(MEX) EQUIVALENCE (I_CODE,ICODE),(I_NEXT,INEXT),(I_LEX,ILEX) EQUIVALENCE (I_NEX,IMEX),(I_LEX,ILEX),(I_XNEXT,IXNEXT) INTEGER*2 I2 INTEGER*4 I4 EQUIVALENCE (I2,I4) * Data DATA LUN_1/0/, LUN_2/0/ * Code * * Save current short title DO I=1,32 SAVED(I) = LINDEX(I) ENDDO * * initializations IER = 1 IF (LUN_1.EQ.0) IER = SIC_GETLUN(LUN_1) IF (LUN_2.EQ.0) IER = SIC_GETLUN(LUN_2) IF (IER.NE.1) THEN ERROR = .TRUE. CALL MESSAGE(8,4,'INPUT','No logical unit left') RETURN ENDIF * * Save current unit to help error recovery ILUN0 = ILUN IF (NSPEC.EQ.ONSPEC .AND. SPEC(1:NSPEC).EQ.OSPEC(1:ONSPEC)) THEN * The same file is already opened on unit OLUN IF (ILUN.NE.OLUN.AND.ILUN.NE.0) CLOSE(UNIT=ILUN) ILUN = OLUN ELSE IF (ILUN.NE.0 .AND. ILUN.EQ.OLUN) THEN * A file is already opened for Input and Output on unit OLUN/ILUN * Allocate the other available unit and open it IF (OLUN.EQ.LUN_1) THEN ILUN = LUN_2 ELSE ILUN = LUN_1 ENDIF ELSE * A file may have been opened for Input only on unit ILUN * Close the Input unit or allocate it, and open it IF (ILUN.EQ.0) THEN IF (OLUN.NE.LUN_1) THEN ILUN = LUN_1 ELSE ILUN = LUN_2 ENDIF ELSE CLOSE(UNIT=ILUN) ENDIF ENDIF FILNAM = SPEC(1:NSPEC) C+VMS c OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384, c $ SHARED,READONLY,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ SHARED,READONLY,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ IOSTAT=IER) C-UNIX-ULTRIX IF (IER.NE.0) THEN ERROR = .TRUE. MESS = 'Open error file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'INPUT',MESS) CALL MESSIOS(8,4,'INPUT',IER) GOTO 19 ENDIF ENDIF * * Now check the data structure READ(ILUN,REC=1,ERR=11,IOSTAT=IER) $ICODE,INEXT,ILEX,IMEX,IXNEXT,IEX1 * * Find conversion code if needed CALL CONVCOD (CODE1,ICODE,ICONVE,FROM_OLD) IF (ICONVE.LT.0) GOTO 12 ! Unknown conversion code * Old format patch IF (FROM_OLD) THEN ICODE = 0 ! Zero the high order bytes, which won't be f INEXT = 0 ! by I*2 read ILEX = 0 IMEX = 0 IXNEXT= 0 READ(ILUN,REC=1,ERR=11,IOSTAT=IER) $ I_CODE,I_NEXT,I_LEX,I_NEX,I_XNEXT,I_EX DO I=1,MEX I2 = I_EX(I) IEX(I) = I4 ENDDO ELSE READ(ILUN,REC=2,ERR=11,IOSTAT=IER) IEX2 ENDIF * * Swap integers if required IF (ICONVE.GT.2) THEN CALL IEI4EI (INEXT,INEXT,127) CALL IEI4EI (IEX2,IEX2,128) ENDIF * * read the index : Read all blocks even first one XBL = -1 XLUN = 0 DO I = 1, IXNEXT-1 CALL RIX (I,ERROR) IF (ERROR) GOTO 100 IX_NUM(I) = LNUM IX_BLOC(I) = LBLOC IX_VER(I) = LVER IX_KIND(I) = LKIND IX_QUAL(I) = LQUAL IX_SCAN(I) = LSCAN IX_DOBS(I) = LDOBS ENDDO * * Reset EIX routine CALL EIX(-1,IER,.FALSE.,ERROR) * * Reset the current index : CALL ZERO * * OK Reset the input file name and acknowledge the operation INSPEC=NSPEC ISPEC =SPEC(1:NSPEC) INQUIRE (UNIT=ILUN,NAME=NAME) MESS = NAME(1:LENC(NAME))//' successfully opened' CALL MESSAGE(1,1,'INPUT',MESS) GOTO 100 * * Various errors 11 ERROR = .TRUE. MESS = 'Read error file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'INPUT',MESS) CALL MESSIOS(8,4,'INPUT',IER) GOTO 19 12 ERROR = .TRUE. MESS = 'Non-standard file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'INPUT',MESS) * * Try to recover from the error 19 IF (ILUN.NE.OLUN) CLOSE(UNIT=ILUN) ILUN = ILUN0 IF (ISPEC.EQ.' ' .OR. ILUN0.EQ.0) GOTO 100 * * Reopen the file if necessary IF (ILUN.NE.OLUN) THEN FILNAM = ISPEC(1:INSPEC) C+VMS c OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384, c $ SHARED,READONLY,ERR=20,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, C $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ SHARED,READONLY,ERR=20,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ ERR=20,IOSTAT=IER) C-UNIX-ULTRIX ENDIF IF (FROM_OLD) THEN READ(UNIT=ILUN,REC=1,ERR=20,IOSTAT=IER) $ I_CODE,I_NEXT,I_LEX,I_NEX,I_XNEXT,I_EX ICODE = I_CODE INEXT = I_NEXT ILEX = I_LEX IXNEXT= I_XNEXT DO I=1,MEX IEX(I) = I_EX(I) ENDDO ELSE READ(ILUN,REC=1,ERR=20,IOSTAT=IER) $ ICODE,INEXT,ILEX,IMEX,IXNEXT,IEX1 READ(ILUN,REC=2,ERR=20,IOSTAT=IER) IEX2 CALL CONVCOD (CODE1,ICODE,ICONVE,FROM_OLD) IF (ICONVE.GT.2) THEN CALL IEI4EI (INEXT,INEXT,127) CALL IEI4EI (IEX2,IEX2,128) ENDIF ENDIF XLUN=-1 XBL=-1 INQUIRE (UNIT=ILUN,NAME=NAME) MESS = NAME(1:LENC(NAME))//' is reopened' CALL MESSAGE(2,1,'INPUT',MESS) GOTO 100 20 CALL MESSIOS(6,3,'INPUT',IER) CALL MESSAGE(6,2,'INPUT','No input file opened') GOTO 100 * ENTRY OUTPUT(SPEC,NSPEC,LSHARE,ERROR) C---------------------------------------------------------------------- C LAS Internal routine C Close any output file, set the file specifications for output C open this file. C (also selected for input if infile not defined) C Output files also shared (R.L. 20-04-84 Pico Veleta) C Arguments : C SPEC C*(*) File name Input C NSPEC I Length of SPEC Input C LSHARE L Is file to be shared Input C ERROR L Logical error flag Output C---------------------------------------------------------------------- * * Save current short title DO I=1,32 SAVED(I) = LINDEX(I) ENDDO IER = 1 IF (LUN_1.EQ.0) IER = SIC_GETLUN(LUN_1) IF (LUN_2.EQ.0) IER = SIC_GETLUN(LUN_2) IF (IER.NE.1) THEN ERROR = .TRUE. CALL MESSAGE(8,4,'INPUT','No logical unit left') RETURN ENDIF OLUN0 = OLUN IF (NSPEC.EQ.INSPEC .AND. SPEC(1:NSPEC).EQ.ISPEC(1:NSPEC)) THEN * The input file is identical to the output file IF (ILUN.NE.OLUN.AND.OLUN.NE.0) CLOSE(UNIT=OLUN) OLUN = ILUN ELSEIF (ILUN.NE.0 .AND. ILUN.EQ.OLUN) THEN * A file is already opened for Input and Output on unit ILUN * Allocate the other available unit and open it IF (OLUN.EQ.LUN_1) THEN OLUN = LUN_2 ELSE OLUN = LUN_1 ENDIF ELSE * A file may have been opened for Output only on unit OLUN * Close the Output unit or allocate it, and open it. IF (OLUN.EQ.0) THEN IF (ILUN.NE.LUN_2) THEN OLUN = LUN_2 ELSE OLUN = LUN_1 ENDIF ENDIF ENDIF * * In any case, close the output file and reopen it with write access CLOSE (UNIT=OLUN) FILNAM = SPEC(1:NSPEC) IF (LSHARE) THEN C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384, c $ SHARED,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ SHARED,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ IOSTAT=IER) C-UNIX-ULTRIX ELSE C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384, c $ IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ IOSTAT=IER) C-UNIX-ULTRIX ENDIF IF (IER.NE.0) THEN ERROR = .TRUE. MESS = 'Open error file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'OUTPUT',MESS) CALL MESSIOS(8,4,'OUTPUT',IER) GOTO 29 ENDIF READ(OLUN,REC=1,ERR=14,IOSTAT=IER) $ICODE,ONEXT,OLEX,OMEX,OXNEXT,OEX1 CALL CONVCOD (CODE1,ICODE,OCONVE,TO_OLD) IF (OCONVE.LT.0) GOTO 15 IF (TO_OLD) THEN CALL MESSAGE(6,3,'OUTPUT','Old format not supported') ERROR = .TRUE. ! CLASS GOTO 29 ! CLASS ENDIF READ(OLUN,REC=2,ERR=14,IOSTAT=IER) OEX2 * * Swap integers if required IF (OCONVE.GT.2) THEN CALL IEI4EI (ONEXT,ONEXT,127) CALL IEI4EI (OEX2,OEX2,128) ENDIF * * read the index XBL = -1 XLUN = 0 DO I = 1, OXNEXT-1 CALL ROX (I,ERROR) IF (ERROR) GOTO 100 OX_NUM(I) = LNUM OX_BLOC(I) = LBLOC OX_VER(I) = LVER ENDDO INQUIRE (UNIT=OLUN,NAME=NAME) MESS = NAME(1:LENC(NAME))//' successfully opened' CALL MESSAGE(1,1,'OUTPUT',MESS) XLUN=-1 XBL =-1 ONSPEC=NSPEC OSPEC =SPEC(1:NSPEC) SHARE =LSHARE GOTO 100 * * Error section 14 ERROR = .TRUE. MESS = 'Read error file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'OUTPUT',MESS) CALL MESSIOS(8,4,'OUTPUT',IER) GOTO 29 15 ERROR = .TRUE. MESS = 'Non-standard file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'OUTPUT',MESS) * * Try to recover from the error 29 IF (ILUN.NE.OLUN) THEN CLOSE(UNIT=OLUN) ELSEIF (ILUN.NE.0 .AND. ISPEC.NE.' ') THEN CLOSE (UNIT=OLUN) ! Was missing ??? FILNAM = ISPEC(1:INSPEC) C+VMS c OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384, c $ READONLY, SHARED,ERR=30,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ READONLY, SHARED,ERR=30,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=ILUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ ERR=30,IOSTAT=IER) C-UNIX-ULTRIX ENDIF OLUN = OLUN0 IF (OSPEC.EQ.' ' .OR. OLUN0.EQ.0) GOTO 100 FILNAM = OSPEC(1:ONSPEC) IF (SHARE) THEN C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,SHARED,ERR=30,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ SHARED,ERR=30,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ ERR=30,IOSTAT=IER) C-UNIX-ULTRIX ELSE C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,ERR=30,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ ERR=30,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ ERR=30,IOSTAT=IER) C-UNIX-ULTRIX ENDIF READ(OLUN,REC=1,ERR=30,IOSTAT=IER) $ICODE,ONEXT,OLEX,OMEX,OXNEXT,OEX1 READ(OLUN,REC=2,ERR=30,IOSTAT=IER) OEX2 CALL CONVCOD (CODE1,ICODE,OCONVE,TO_OLD) * * Swap integers if required IF (OCONVE.GT.2) THEN CALL IEI4EI (ONEXT,ONEXT,127) CALL IEI4EI (OEX2,OEX2,128) ENDIF INQUIRE (UNIT=OLUN,NAME=NAME) MESS = NAME(1:LENC(NAME))//' is reopened' CALL MESSAGE(2,1,'OUTPUT',MESS) GOTO 100 30 CALL MESSIOS(6,3,'OUTPUT',IER) CALL MESSAGE(6,2,'OUTPUT','No output file opened') GOTO 100 * ENTRY NEWPUT (SPEC,NSPEC,LSIZE,LSHARE,ERROR) C---------------------------------------------------------------------- C SAS Internal routine C Initialise an output file C Close any output file, set the file specifications for output C open this file. C Arguments : C SPEC C*(*) Name of file C NSPEC I Length of SPEC C LSIZE I maximum number of observations allowed C LSHARE L Is file to be shared ? C ERROR L Logical error flag C (6-mar-1985) C---------------------------------------------------------------------- * * Save current short title DO I=1,32 SAVED(I) = LINDEX(I) ENDDO * * No test on file name since another version must be created anyway * IER = 1 IF (LUN_1.EQ.0) IER = SIC_GETLUN(LUN_1) IF (LUN_2.EQ.0) IER = SIC_GETLUN(LUN_2) IF (IER.NE.1) THEN ERROR = .TRUE. CALL MESSAGE(8,4,'INPUT','No logical unit left') RETURN ENDIF OLUN0 = OLUN IF (ILUN.NE.0 .AND. ILUN.EQ.OLUN) THEN * A file is already opened for Input and Output on unit ILUN/OLUN * Allocate the other available unit and open it IF (OLUN.EQ.LUN_1) THEN OLUN = LUN_2 ELSE OLUN = LUN_1 ENDIF ELSE * A file may have been opened for Output only on unit OLUN. * Close the Output unit or allocate it, and open it. IF (OLUN.EQ.0) THEN IF (ILUN.NE.LUN_2) THEN OLUN = LUN_2 ELSE OLUN = LUN_1 ENDIF ENDIF ENDIF * * In any case, close the output file and reopen it with write access CLOSE (UNIT=OLUN) FILNAM = SPEC(1:NSPEC) C+VMS c IF (LSHARE) THEN c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='NEW',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,INITIALSIZE=128,EXTENDSIZE=128, c $ SHARED,IOSTAT=IER) c ELSE c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='NEW',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,INITIALSIZE=128,EXTENDSIZE=128, c $ IOSTAT=IER) c ENDIF C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $STATUS='NEW',FORM='UNFORMATTED',RECL=128*FACUNF, c $RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $STATUS='NEW',FORM='UNFORMATTED',RECL=128*FACUNF, $IOSTAT=IER) C-UNIX-ULTRIX IF (IER.NE.0) THEN ERROR = .TRUE. MESS = 'Open error file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'INIT',MESS) CALL MESSIOS(8,4,'INIT',IER) GOTO 39 ENDIF * LSIZE1 = MIN(LSIZE,MAX_RECORD) LSIZE1 = MAX(MEX*64,LSIZE1) OLEX = (LSIZE1/MEX/64) * 64 ONEXT = 3+OLEX/4 OXNEXT = 1 OMEX = 1 OEX(1) = 3 ! Start at bloc number 3 DO I=1,LENBUF XBUF(I)=0 ENDDO DO I=1,OLEX/4 WRITE(OLUN,REC=I+2,ERR=17,IOSTAT=IER) XBUF ENDDO WRITE(OLUN,REC=1,ERR=17,IOSTAT=IER) $CODE1,ONEXT,OLEX,OMEX,OXNEXT,OEX1 WRITE(OLUN,REC=2,ERR=17,IOSTAT=IER) OEX2 * * Close and reopen the file to flush first blocks INQUIRE (UNIT=OLUN,NAME=NAME) CLOSE (UNIT=OLUN) OSPEC = FILNAM ONSPEC = LENC(OSPEC) LNAME = LENC(NAME) FILNAM = NAME(1:LNAME) IF (LSHARE) THEN C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,SHARED,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ SHARED,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ IOSTAT=IER) C-UNIX-ULTRIX ELSE C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ IOSTAT=IER) C-UNIX-ULTRIX ENDIF IF (IER.NE.0) THEN ERROR = .TRUE. MESS = 'Open error file '//SPEC(1:NSPEC) CALL MESSAGE(8,4,'INIT',MESS) CALL MESSIOS(8,4,'INIT',IER) GOTO 39 ENDIF MESS = NAME(1:LNAME)//' initialized' CALL MESSAGE(1,1,'INIT',MESS) XLUN=-1 XBL =-1 SHARE = LSHARE OCONVE = 0 ! No conversion in such a case GOTO 100 * * Error 17 ERROR = .TRUE. MESS = 'Write error file '//SPEC(1:NSPEC) CALL MESSAGE(8,3,'INIT',MESS) CALL MESSIOS(8,3,'INIT',IER) * * Try to recover from the error 39 CLOSE(UNIT=OLUN) OLUN = OLUN0 IF (OSPEC.EQ.' ' .OR. OLUN0.EQ.0) GOTO 100 FILNAM = OSPEC(1:ONSPEC) IF (SHARE) THEN C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,SHARED,ERR=40,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ SHARED,ERR=40,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ ERR=40,IOSTAT=IER) C-UNIX-ULTRIX ELSE C+VMS c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ BLOCKSIZE=16384,ERR=40,IOSTAT=IER) C-VMS C+ULTRIX c OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', c $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, c $ RECORDTYPE='FIXED',ORGANIZATION='SEQUENTIAL', c $ ERR=40,IOSTAT=IER) C-ULTRIX C+UNIX-ULTRIX OPEN (UNIT=OLUN,FILE=FILNAM,ACCESS='DIRECT', $ STATUS='OLD',FORM='UNFORMATTED',RECL=128*FACUNF, $ ERR=40,IOSTAT=IER) C-UNIX-ULTRIX ENDIF READ (OLUN,REC=1,ERR=40,IOSTAT=IER) $ICODE,ONEXT,OLEX,OMEX,OXNEXT,OEX1 READ (OLUN,REC=2,ERR=40,IOSTAT=IER) OEX2 CALL CONVCOD(CODE1,ICODE,OCONVE,TO_OLD) IF (OCONVE.GT.2) THEN CALL IEI4EI (ONEXT,ONEXT,127) CALL IEI4EI (OEX2,OEX2,128) ENDIF INQUIRE (UNIT=OLUN,NAME=NAME) MESS = NAME(1:LENC(NAME))//' is reopened' CALL MESSAGE(2,1,'OUTPUT',MESS) GOTO 100 40 CALL MESSIOS(6,3,'OUTPUT',IER) CALL MESSAGE(6,3,'OUTPUT','No output file opened') GOTO 100 * 100 DO I=1,32 LINDEX(I) = SAVED(I) ENDDO RETURN * ENTRY INFO C---------------------------------------------------------------------- C SAS Internal routine C Prints input and output file names C Use of message suppressed C---------------------------------------------------------------------- IF (ILUN.LE.0) THEN WRITE(6,1000) 'No input file opened' ELSE IF (ICONVE.GE.0 .AND. ICONVE.LE.MCONVE) THEN ACONV = CONVERSION(ICONVE) ELSE ACONV = ' [Unsupported Format]' ENDIF INQUIRE(UNIT=ILUN,NAME=NAME) WRITE(6,1000) 'Input file ',NAME(1:LENC(NAME)),ACONV ENDIF IF (OLUN.LE.0) THEN WRITE(6,1000) 'No output file opened' ELSE IF (OLUN.NE.ILUN) THEN INQUIRE(UNIT=OLUN,NAME=NAME) IF (OCONVE.GE.0 .AND. OCONVE.LE.MCONVE) THEN ACONV = CONVERSION(OCONVE) ELSE ACONV = ' [Unsupported Format]' ENDIF ENDIF WRITE(6,1000) 'Output file ',NAME(1:LENC(NAME)),ACONV ENDIF 1000 FORMAT(1X,10(A)) END