Trailing-Edge
-
PDP-10 Archives
-
tops10_integ_tools_v4_10jan-86
-
70,6067/convrt/convrt.for
There are 4 other files named convrt.for in the archive. Click here to see a list.
PROGRAM READ10
C
C
C A PROGRAM TO READ DECSYSTEM - 10 BACKUP FORMAT MAGTAPES.
C
C
C REVISION HISTORY:
C (0) 83 JAN 31 20:05 P.J.HURST INITITIAL VERSION
C (1) 83 FEB 02 20:10 P.J.HURST ADD USER MENU FEATURES
C (2) 83 FEB 04 09:20 P.J.HURST ADD EOT HANDLING
C (3) 83 FEB 15 14:38 P.J.HURST ADD FILENAME HANDELING
C (3A) 83 FEB 26 18:10 K.S.LARUE MV8000 VERSION
C ADDED BUFFER LENGTH HANDLING
C (4) 83 MAR 29 09:45 P.J.HURST ADDED 3A REV TO VAX VERSION
C
C
PARAMETER OUTPUT = 16
LOGICAL*1 INPUTBUFFER(2720)
LOGICAL*1 OUTPUTBUFFER(2560)
LOGICAL*1 REALDATA(2560)
LOGICAL*1 NAME(10)
LOGICAL*1 EXTENTION(5)
LOGICAL*1 SAVESET(64)
BYTE RECORDTYPE
BYTE MODEDEPENDENT
BYTE HEADERDATA(160)
INTEGER*4 ITIMES
INTEGER*4 POSITION
LOGICAL*1 ONAME(21)
LOGICAL*1 OPENFLAG
LOGICAL*1 SSSEARCHFLAG
LOGICAL*1 DIRFLAG
LOGICAL*1 CONTFLAG
LOGICAL*1 EOTFLAG
C.... CHARACTER*10 NSHORTER,NSHORT
C.... CHARACTER*1 NONAME(21)
CHARACTER*1 DATALENGTH(5)
CHARACTER*1 DATASKIP(5)
INTEGER*4 DLENGTH
INTEGER*4 DSKIP
C
C
C
C ADDED VARS FOR FAKE OPEN FOR THE MAGTAPE
C
INTEGER*4 TFUNCT
CHARACTER*10 MNAME
INTEGER*4 TAPEDESC(2)
LOGICAL*1 TAPENAME(64)
INTEGER*4 TAPECHANNEL
C
C
C
INTEGER STATUS,COUNTER,I,BLOCKER
LOGICAL*1 SSNFLAG,FILEFLAG
LOGICAL*1 SSNAME(80),SHORT(10),SHORTER(10),CONTINUE
EQUIVALENCE (INPUTBUFFER(161),REALDATA(1))
EQUIVALENCE (INPUTBUFFER(171),NAME(1))
EQUIVALENCE (INPUTBUFFER(181),EXTENTION(1))
EQUIVALENCE (INPUTBUFFER(161),SAVESET(1))
EQUIVALENCE (INPUTBUFFER(5),RECORDTYPE)
EQUIVALENCE (INPUTBUFFER(1),HEADERDATA(1))
EQUIVALENCE (INPUTBUFFER(16),MODEDEPENDENT)
C.... EQUIVALENCE (SHORT,NSHORT)
C.... EQUIVALENCE (SHORTER,NSHORTER)
C.... EQUIVALENCE (NONAME(1),ONAME)
EQUIVALENCE (INPUTBUFFER(26),DATALENGTH(1))
EQUIVALENCE (INPUTBUFFER(31),DATASKIP(1))
C
C
C
C
C GLOBAL ADDRESSES NEEDED FOR THE FAKE OPEN...
C
C
INTEGER*4 IO$_SETMODE
INTEGER*4 IO$_READVBLK
INTEGER*4 IO$_WRITEBLK
INTEGER*4 IO$M_CTRLCAST
INTEGER*4 SS$_NORMAL
INTEGER*4 SYS$ASSIGN
INTEGER*4 SYS$QIOW
INTEGER*4 SYS$TRNLOG
INTEGER*4 IO$_REWIND
INTEGER*4 SS$_ENDOFTAPE
C
C
C
EXTERNAL IO$_SETMODE
EXTERNAL IO$_READVBLK
EXTERNAL IO$_WRITEVBLK
EXTERNAL IO$M_CTRLCAST
EXTERNAL SS$_NORMAL
EXTERNAL IO$_REWIND
EXTERNAL SS$_ENDOFTAPE
C
C
C
C
C
C OPEN(UNIT=TAPEIN,FILE='MTA0:',
C 1 STATUS='OLD',ERR=9991,FORM='UNFORMATTED',
C 2 IOSTAT=STATUS,ORGANIZATION='SEQUENTIAL',
C 3 READONLY,RECL=680,BLOCKSIZE=5440 )
C
C
C OPEN THE MTA: AS THE INPUT UNIT....
C USING A KLUDGE METHOD TO REPLACE THE NORMAL FORTRAN OPEN AND
C READ WHICH DOES NOT WORK VERY WELL WITH ODD SIZED BLOCKS WITH
C STRANGE DATA THEREIN ... UNDER VMS...
C
C
C
C PROMPT USER FOR THE NAME OF THE MAGTAPE ,,,
C
920 FORMAT(1X,'DEVICE TO BE READ FROM ?',$)
100 WRITE(6,920)
921 FORMAT(1A10)
READ(5,921) MNAME
C
C NOW THAT WE HAVE WHAT WE THINK IS A TAPE DRIVE OPEN IT..
C
TAPEDESC(1)=64
TAPEDESC(2)=%LOC(TAPENAME)
C
C GET THE LOGICAL NAME ASSOCIATION
C
STATUS=SYS$TRNLOG(MNAME,TAPEDESC,TAPEDESC,,,)
C
C
C NOW CHECK TO SEE IF THIS NAME EXISTS...
C
IF(STATUS.NE.%LOC(SS$_NORMAL))THEN
CALL ERROR_CHECK(TAPECHANNEL,STATUS)
END IF
C
C NOW TO OPEN THE DRIVE...
C
STATUS=SYS$ASSIGN(TAPEDESC,TAPECHANNEL,,)
C
C AND CHECK TO SEE IF THIS WAS SUCESSFUL
C
IF (STATUS.NE.%LOC(SS$_NORMAL)) GO TO 9991
C
C ;REMOVED BY THE USER MENU
C OPEN(UNIT=OUTPUT,FILE='PJH',STATUS='NEW',
C 1 ERR=9992,FORM='UNFORMATTED',IOSTAT=STATUS,
C 2 ORGANIZATION='SEQUENTIAL',
C 3 ASSOCIATEVARIABLE=POSITION,
C 4 ACCESS='DIRECT',RECL=64)
C
EOTFLAG = .FALSE.
OPENFLAG= .FALSE.
SSNFLAG = .FALSE.
FILEFLAG= .FALSE.
SSSEARCHFLAG=.FALSE.
DIRFLAG = .FALSE.
CONTFLAG= .FALSE.
POSITION=1
COUNTER = 0
BLOCKER = 0
C
C NOW TYPE THE COMMAND MENU TO THE USER 1ST BEFORE ANYTHING ELSE HAPPENS
C
CALL MENU
C
C REWIND THE TAPE SO WE CAN START PROCESSING THIS TAPE
C
TFUNCT=%LOC(IO$_REWIND)
STATUS=SYS$QIOW(,%VAL(TAPECHANNEL),%VAL(TFUNCT),,,,,,,,,,)
C
C NOW CHECK TO SEE IF ALL IS WELL WITH THE WORLD AND THE TAPE DRIVE
C HAS GONE TO BOT WITHOUT A WIMPER (ERROR THAT IS)
C
IF (STATUS.NE.%LOC(SS$_NORMAL)) THEN
CALL ERROR_CHECK(TAPECHANNEL,STATUS)
END IF
C
C
C
C REWIND(TAPEIN)
C READ A BLOCK FROM THE 10 TAPE TO BE TRANSLATED...
C
10 COUNTER = COUNTER+1
C READ(TAPEIN,IOSTAT=STATUS,ERR=9994,END=9993) INPUTBUFFER
C
C
C KLUDGE TO READ A BLOCK OF DATA FOR A MAGTAPE
C
TFUNCT=%LOC(IO$_READVBLK)
STATUS = SYS$QIOW(,%VAL(TAPECHANNEL),%VAL(TFUNCT),,,,INPUTBUFFER,
1 %VAL(2720),,,,)
C
C NOW CHECH TO SEE IF THE TAPE READ SUCESSFULLY
C
IF((STATUS.EQ.%LOC(SS$_ENDOFTAPE)).OR.
1 ((RECORDTYPE.EQ.3).AND.EOTFLAG)) THEN
C
C IF THE PHYSICAL OR LOGICAL EOT IS REACHED, THEN GIVE UP!!!!
C THAT IS RESET TAPE AND THE PROGRAM TO THE INITIAL STATE AND
C REWIND TO THE BEGINNING.....
C
C 1ST THINGS CLOSE THE POSSIBLE OUTPUT FILE .....
C
IF(OPENFLAG) THEN
CLOSE(OUTPUT)
OPENFLAG=.FALSE.
END IF
C
C NOW RESET ALL FLAGS COUNTERS ET AL TO INDICATE THIS IS A NEW
C TAPE..... IE REINIT IT...
C
COUNTER = 0
BLOCKER = 0
POSITION= 0
OPENFLAG=.FALSE.
SSNFLAG =.FALSE.
FILEFLAG=.FALSE.
SSSEARCHFLAG=.FALSE.
DIRFLAG =.FALSE.
CONTFLAG=.FALSE.
C
C NOW ATTEMPT TO REWIND THIS TAPE TO THE BEGINNING
C
TFUNCT=%LOC(IO$_REWIND)
STATUS=SYS$QIOW(,%VAL(TAPECHANNEL),%VAL(TFUNCT),,,,,,,,,,,)
C
C NOW CHECK TO SEE IF ALL IS WELL
C
IF(STATUS.NE.%LOC(SS$_NORMAL)) THEN
CALL ERROR_CHECK(TAPECHANNEL,STATUS)
END IF
C
C NOW TAPE SHOULD BE REINITTED
C
935 FORMAT(/,1X,'EOT REACHED ......... REWIND INITIATED ',/)
WRITE(6,935)
GO TO 10
END IF
C
IF (STATUS.NE.%LOC(SS$_NORMAL)) GO TO 9994
C .... ....
C FOR DEBUGGING
C
C900 FORMAT(1X,'FILEFLAG IS ',L5,' , SSNAMEFLAG IS ',L5,
C 1 ' BLOCK IS ',I5,' RECORD TYPE IS ',O3,' MODE IS ',O3,/)
C WRITE(6,900) FILEFLAG,SSNFLAG,COUNTER,RECORDTYPE,MODEDEPENDENT
C
C
C NOW LETS DIFFERENTIATE BETWEEN THE DIIFFERENT TYPES OF BLOCKS
C
C 10 RECORD TYPE ID .. WORD #1 .... 1ST 5 BYTES ON THE TAPE
C
C RECORD TYPE = 1 LABEL RECORD
C = 2 START OF SAVE SET
C = 3 END OF SAVE SET
C = 4 FILE RECORD
C = 5 UFD RECORD
C = 6 END OF VOLUME
C = 7 COMMENT
C
C .. WORD #3 .... BYTE 16
C
C MODE DEPENDENT(BITS)= 1-8 UNUSED RESERVED FOR EXPANSION
C = 16 THIS IS SET IF 1ST TAPE BLOCK
C = 32 NO CHECKSUM FOR THIS BLOCK
C = 64 THIS IS A REPEAT OF THE LAST BLOCK
C = 128 LAST BLOCK FOR THIS FILE (CAN BE THE 1ST)
C
C
C
C
IF (RECORDTYPE.EQ.2) THEN
SSNFLAG=.TRUE.
BLOCKER = 0
IF(SSSEARCHFLAG.AND.DIRFLAG.AND..NOT.CONTFLAG) DIRFLAG=.FALSE.
IF(.NOT.CONTFLAG) SSSEARCHFLAG=.FALSE.
CALL CONVRT10(SAVESET,65,SSNAME,80)
C
C CONVERT THE PIECE OF THE INPUT BUFFER WHICH CONTAINS THE SSNAME TO
C ASCII AND THEN DISPLAY IT FOR THE USER.
C
901 FORMAT(/,1X,' -=- THE SAVESET IS : ',80A1,' -=-',/,/)
WRITE(6,901) (SSNAME(I),I=1,80)
END IF
C
C IF WE ARE SEARCHING FOR A NEW SAVE SET THE RECYCLE 'TILL FOUND
C IE SKIP 'TILL ALL OTHER PROCESSING (READ A NEW BLOCK) UNLESS
C DIRECTORY SEARCHING IS IN PROGRESS...
C
C
IF(SSSEARCHFLAG.AND.(.FALSE..EQ.DIRFLAG)) GO TO 10
C
C IE RECYCLE
C
C
C
IF (RECORDTYPE.EQ.3) THEN
FILEFLAG=.FALSE.
SSNFLAG =.FALSE.
C EOTFLAG =.TRUE.
IF(OPENFLAG) THEN
C WERE AT THE END OF THE FILE SO CLOSE THE USERS FILE SO IT IS COMPLETE
CLOSE(OUTPUT)
OPENFLAG=.FALSE.
END IF
ELSE
EOTFLAG =.FALSE.
END IF
C
C
C
101 IF(RECORDTYPE.EQ.4) THEN
C
C IS IT A HEADER???
C
IF(16.EQ.(16.AND.MODEDEPENDENT)) THEN
SSNFLAG = .FALSE.
C
C CHECK TO MAKE SURE OPEN FILES ARE CLOSED BEFORE NEW ONES
C ARE OPENED..
C
IF(OPENFLAG) THEN
CLOSE(OUTPUT)
OPENFLAG=.FALSE.
END IF
C SET BLOCK COUNT PER FILE TO ZERO
C
BLOCKER=0
C
C YEP A HEADER SO LETS GO....
C
CALL CONVRT10(NAME,10,SHORT,10)
C
C AND ALSO GET THE EXTENTION
C
CALL CONVRT10(EXTENTION,10,SHORTER,10)
C
C MAKE FILE && EXTENTION INTO A STRING WITH A DOT DELIMETER
C
C.... ONAME=NSHORT//'.'//NSHORTER
C ADD A '.' INTO THE FILESPEC
DO 105 I=1,10
ONAME(I)=SHORT(I)
105 CONTINUE
ONAME(11)='.'
DO 106 I=1,10
ONAME(I+11)=SHORTER(I)
106 CONTINUE
C
C NOW REMOVE ALL JUNK CHARACTERS
C
CALL FIXUP(ONAME,ONAME,21)
C
C
C IS THIS A DIRECTORY MODE OPERATION OR JUST A NORMAL
C USER QUERY
C
IF(DIRFLAG) THEN
C
C NO QUERY IF DIR MODE FLAG IS SET, JUST PRINT THE NAME AND BE DONE
C WITH IT.
C
WRITE(6,930) COUNTER,ONAME
930 FORMAT(1X,'FILE AT ',I10,' IS :',21A1,': ',$)
C
END IF
C
IF(.NOT.DIRFLAG) THEN
C
C
902 FORMAT(1X,' @ BLOCK: ',I10,' NAME : ',21A1,' ?',$)
WRITE(6,902) COUNTER,ONAME
903 FORMAT(1A1)
READ(5,903) CONTINUE
IF((CONTINUE.EQ.'Y').OR.(CONTINUE.EQ.'T').OR.
1 (CONTINUE.EQ.'A')) THEN
IF(CONTINUE.NE.'A') THEN
922 FORMAT(' OUTPUT AS ?',$)
WRITE(6,922)
923 FORMAT(22A1)
READ(5,923) ONAME
ONAME(22)=00
END IF
C
C NOW THAT WE HAVE THE FILENAME OPEN THE FILE... (HOPEFULLY)
C
OPEN(UNIT=OUTPUT,FILE=ONAME,STATUS='NEW',
1 ERR=9992,FORM='FORMATTED',
2 ORGANIZATION='SEQUENTIAL',IOSTAT=STATUS,
3 CARRIAGECONTROL='NONE')
C
C OPENED THE FILE CORRECTLY NOW INIT ITS POINTER
C
POSITION=1
C
C MARK THE FILE AS BEING OPEN
C
OPENFLAG=.TRUE.
C
C
C
FILEFLAG = .TRUE.
END IF
END IF
C
C IS IT A REWIND COMMAND ????? (MAYBE)
C
IF(CONTINUE.EQ.'R') THEN
C
C IT IS A REWIND SO DO IT
C
TFUNCT=%LOC(IO$_REWIND)
STATUS=SYS$QIOW(,%VAL(TAPECHANNEL),%VAL(TFUNCT),,,,,,,,,,)
C
C CHECK TO SEE IF TAPE WENT TO BOT IN ONE PIECE
C
IF(STATUS.NE.%LOC(SS$_NORMAL)) THEN
CALL ERROR_CHECK(TAPECHANNEL,STATUS)
END IF
C
C ALL DONE WITH REWIND
C
END IF
C
C IS THE COMMAND TO 'S'KIP THE CURRENT FILE
C
IF((CONTINUE.EQ.'S').OR.(CONTINUE.EQ.'N')) THEN
FILEFLAG=.FALSE.
END IF
C
C
C IS THE COMMAND 'V' TO SKIP TO THE NEXT SAVESET???
C
IF(CONTINUE.EQ.'V')THEN
SSSEARCHFLAG=.TRUE.
C IF SO, THEN SET THE PROGRAM TO CYCLE THROUGH ALL THE FILES
END IF
C
C IS THE COMMAND 'L' -- LIST DIRECTORY 'TILL NEXT SAVE SET ????
IF(CONTINUE.EQ.'L') THEN
DIRFLAG=.TRUE.
SSSEARCHFLAG=.TRUE.
C
C IF SO THEN SET THE PROGRAM TO CYCLE THROUGH ALL THE FILES
C DISPLAYING THERE NAMES 'TILL LIMITED BY THE SAVESET SEARCH
C INDICATION.
C
END IF
C
C IS THE COMMAND 'Z' -- TO LIST ALL THE SAVESETS FROM THE CURRENT
C POSITION???
C
IF(CONTINUE.EQ.'Z') THEN
CONTFLAG=.TRUE.
SSSEARCHFLAG=.TRUE.
DIRFLAG=.FALSE.
C
C SET THE PROGRAM TO MOVE CONTINOUSLY THRU THE TAPE 'TILL THE
C EOT IS REACHED...
C
END IF
C
C
C IS THE COMMAND 'D' -- LIST A FULL DIRECTORY OF THE ENTIRE TAPE
C
IF(CONTINUE.EQ.'D')THEN
CONTFLAG=.TRUE.
SSSEARCHFLAG=.TRUE.
DIRFLAG=.TRUE.
C
C SET THE PROGRAM TO MOVE CONTINUOUSLY THROUGH THE TAPE DOING
C A DIRECTORY ALONG THE WAY..
C
END IF
C
C IS THE COMMAND 'E' -- TO EXIT THIS SILLY PROGRAM
C
IF(CONTINUE.EQ.'E') THEN
IF(OPENFLAG) THEN
CLOSE(OUTPUT)
OPENFLAG=.FALSE.
END IF
STOP 00
END IF
C
C
C IS THE COMMAND H -- HELP WHICH PRINTS THE MENU FOR THE USER??
C
IF(CONTINUE.EQ.'H')THEN
CALL MENU
END IF
END IF
C
IF(FILEFLAG.AND.(64.NE.(64.AND.MODEDEPENDENT))) THEN
C
C IF FILEFLAG AND A DATA BLOCK THEN IT IS TIME TO BURP THIS
C OUT TO THE USER...
C
C UPDATE THE FILESIZE PARAMETER FOR THE FILE
C
C
DLENGTH=ICHAR(DATALENGTH(4))*16+IAND(15,ICHAR(DATALENGTH(5)))
DSKIP =ICHAR(DATASKIP(4)) *16+IAND(15,ICHAR(DATASKIP(5)))
C -=- NOW CONNVERT THE ENTIRE BUFFER TO ASCII -=-
C
C
C
C
C
C WRITE(6,9291) DSKIP,DLENGTH
C
C
CALL CONVRT10(REALDATA,2560,OUTPUTBUFFER,2560)
IF(DLENGTH.GT.0) WRITE (OUTPUT,9293) (OUTPUTBUFFER(I),
1 I=DSKIP*5+1,(DLENGTH+DSKIP)*5)
9293 FORMAT(1A1)
904 FORMAT(80A1,$)
C
C9291 FORMAT (1X,'.... DSKIP ==',I6,' DLEN ==',I6,/)
C
BLOCKER=BLOCKER+1
END IF
C
C
IF(128.EQ.(128.AND.MODEDEPENDENT)) THEN
C
C IS THIS THE LAST BLOCK OF THE FILE?
C
C
C NOTIFIY THE USER OF THE BYTE COUNT ET AL
C
WRITE(6,941) COUNTER
941 FORMAT(1X,' FILE EXTENDS TO BLOCK ',I5,$)
942 FORMAT(1X,' OCCUPYING ',I5,
1 ' BLOCKS AND ',I10,' BYTES.',/)
943 FORMAT(1X,' OCCUPYING 1 BLOCK AND 2560 BYTES.',/)
IF(BLOCKER.LE.1) THEN
WRITE(6,943)
ELSE
WRITE(6,942) BLOCKER,(BLOCKER*2560)
END IF
C
C RESET BLOCK COUNTER
C
BLOCKER =0
FILEFLAG=.FALSE.
IF(OPENFLAG) THEN
CLOSE(OUTPUT)
OPENFLAG=.FALSE.
END IF
END IF
END IF
C
C RESET OPTION
C
CONTINUE=' '
C
C
C
IF((RECORDTYPE.GE.5).OR.(RECORDTYPE.LT.0)) THEN
905 FORMAT( ' ENTRY UNKNOWN TYPE OF ENTRY IS =',I5,/)
WRITE(6,905) RECORDTYPE
SSNFLAG = .TRUE.
FILEFLAG = .FALSE.
END IF
C
C DO 'TILL DONE
C
GO TO 10
9991 WRITE(6,906)STATUS
906 FORMAT(' ERROR OPENING TAPE STATUS IS ',I6,/)
GO TO 100
9992 WRITE(6,907)STATUS
907 FORMAT(' ERROR OPENING OUTPUT FILE STATUS IS ',I6,/)
GO TO 101
9993 WRITE(6,908) STATUS
908 FORMAT(' END OF TAPE REACHED ERROR IS ',I8,/)
C REWIND(TAPEIN)
CLOSE(OUTPUT)
STOP
9994 WRITE(6,909) STATUS
909 FORMAT(' TAPE ERROR ... IS ',I6,/)
GO TO 10
C
9995 WRITE(6,910) STATUS
910 FORMAT(' LOGICAL ASGN ERROR ... IS ',I6,/)
STOP
9996 WRITE(6,919) STATUS
919 FORMAT(' REWIND ERROR STATUS IS ',I6,/)
STOP
END
C
C
C
SUBROUTINE CONVRT10(INPUT,LENGTH,OUTPUT,LIMIT)
C
C
C A SUBROUTINE WHICH TRANSLATES THE DEC10'S INTERNAL 7 BIT PACKED
C CHARACTER FORMAT INTO 1 CHARACTER PER BYTE AS PER THE VAX
C
C
INTEGER*4 LENGTH
INTEGER*4 LIMIT
LOGICAL*1 INPUT(LENGTH)
LOGICAL*1 OUTPUT(LENGTH)
INTEGER*4 BYTE0,BYTE1,BYTE2,BYTE3,BYTE4
INTEGER*4 COUNT,I,IPACK,XTER
C
C
C INIT COUNTER (INDEX)
COUNT=1
C
C
DO 10 XTER=1,LIMIT,5
C
C
C SPLIT THE INDIVIDUAL BYTES FROM THE INPUT TAPE FORMAT...
BYTE0=INPUT(COUNT)
BYTE1=INPUT(COUNT+1)
BYTE2=INPUT(COUNT+2)
BYTE3=INPUT(COUNT+3)
BYTE4=INPUT(COUNT+4) .AND. '077'O
C
C NOW RE--POSITION THE SEVEN BIT ASCII SO NOW ALL ARE IN A BYTE WORD
C BOUNDARY ZERO FILLED ---> INTO IPACK
C
CALL LIB$INSV(BYTE3,0,8,IPACK)
CALL LIB$INSV(BYTE2,8,8,IPACK)
CALL LIB$INSV(BYTE1,16,8,IPACK)
CALL LIB$INSV(BYTE0,24,8,IPACK)
C
C NOW PLACE EACH 8 BIT ASCII CHARACTER IN ITS APPROPIATE WORD
C (SO WE CAN FILL THE CHARACTER STRING BUFFER)
C
BYTE0=LIB$EXTZV(25,7,IPACK)
BYTE1=LIB$EXTZV(18,7,IPACK)
BYTE2=LIB$EXTZV(11,7,IPACK)
BYTE3=LIB$EXTZV(04,7,IPACK)
BYTE4=LIB$EXTZV(00,4,IPACK)*2**3+BYTE4/2
C
C
C NOW TAKE THE RECOVERED CHARACTERS AND PLACE THEM IN THE OUTPUT
C BUFFER
C
OUTPUT(COUNT)=BYTE0
OUTPUT(COUNT+1)=BYTE1
OUTPUT(COUNT+2)=BYTE2
OUTPUT(COUNT+3)=BYTE3
OUTPUT(COUNT+4)=BYTE4
C
C FOR DEBUGGING
C1001 FORMAT (1X,'COUNT ',I9,' LENGTH ',I9,' LIMIT ',I9,/)
C WRITE (6,1001) COUNT,LENGTH,LIMIT
C
C CONTINUE 'TILL DONE WITH THE BUFFER
C
C
C INDEX INDEX
COUNT=COUNT+5
C
C
10 CONTINUE
RETURN
END
C
C
C
SUBROUTINE MENU
C
C
C TYPE OUT A MENU FOR THE USER ON THE TERMINAL UNIT == 6
C
C
C
10 FORMAT(11X,' CONVRT10 COMMANDS',/,
1 11X,' ',/,
2 11X,' T -- TRANSFER THIS CURRENT FILE TO A VMS DISK FILE',/,
3 11X,' R -- REWIND THE MAGTAPE TO THE BOT POSITION ',/,
4 11X,' S -- SKIP OVER THE CURRENT FILE TO THE NEXT ONE',/)
20 FORMAT(11X,
5 ' V -- SKIP TO THE NEXT SAVE SET',/,
6 11X,' L -- LIST A DIRECTORY OF ALL FILES IN THE CURRENT',/,
7 11X,' SAVE SET <FROM THE CURRENT TAPE POSITION>',/)
30 FORMAT(11X,
1 ' Z -- LIST SAVE SETS <FROM THE CURRENT TAPE POSITION>',/,
2 11X,' D -- LIST A FULL DIRECTORY OF THIS TAPE <FROM THE ',/,
3 11X,' CURRENT TAPE POSITION>',/,
4 11X,' A -- TRANSFER THIS CURRENT FILE USING NAME FROM TAPE',/)
40 FORMAT(11X,
1 ' E -- EXIT THIS PROGRAM ',/,
2 11X,' H -- THIS TEXT',/,
3 11X,' Y -- SAME AS T',/,
4 11X,' N -- SAME AS S',/,/)
C
C
WRITE(6,10)
WRITE(6,20)
WRITE(6,30)
WRITE(6,40)
RETURN
END
SUBROUTINE ERROR_CHECK(DEVICE_CHANNEL,ERROR_STATUS)
C
C Report error message as detected by system.
C
C
C Declare input variables:
C
INTEGER*4 DEVICE_CHANNEL ! Assigned output device channel number
INTEGER*4 ERROR_STATUS ! System error code for interpretation
C
C Declare modified variables:
C
C none
C
C Declare output variables:
C
C none
C
C Declare local variables:
C
CHARACTER*256 ERROR_MESSAGE ! Receives error code interpretation
INTEGER*4 IO_FUNCTION ! Receives I/O function code to perform
INTEGER*4 IO_STATUS ! Receives I/O status return of function
INTEGER*4 MESSAGE_LENGTH ! Receives error interpretation length
INTEGER*4 NULL_DEVICE ! Contains code for a null device
C
C Declare global variables:
C
INTEGER*4 IO$_WRITEVBLK ! Write virtual block I/O function code
INTEGER*4 SS$_NORMAL ! Successful completion of operation
INTEGER*4 SYS$GETMSG !
INTEGER*4 SYS$QIOW !
C
C Declare global addresses:
C
EXTERNAL IO$_WRITEVBLK !
EXTERNAL SS$_NORMAL !
C
C Define local constants:
C
DATA NULL_DEVICE/0/
C
C ////////// begin executable statements:
C
C Define message to tell the user what the error is:
C
IO_STATUS = SYS$GETMSG(%VAL(ERROR_STATUS),
1 MESSAGE_LENGTH,
2 %DESCR(ERROR_MESSAGE),
3 %VAL(15),)
C
C If message is not defined, tell the user this instead:
C
IF (IO_STATUS .NE. %LOC(SS$_NORMAL)) THEN
CALL SYS$GETMSG(%VAL(IO_STATUS),
1 MESSAGE_LENGTH,
2 %DESCR(ERROR_MESSAGE),
3 %VAL(15),)
END IF
C
C Tell the user what the error message is:
C
IF (DEVICE_CHANNEL .EQ. NULL_DEVICE) THEN
WRITE(5,1000) ERROR_MESSAGE(1:MESSAGE_LENGTH)
ELSE
WRITE(5,1000) ERROR_MESSAGE(1:MESSAGE_LENGTH)
C IO_FUNCTION = %LOC(IO$_WRITEVBLK)
C CALL SYS$QIOW(,%VAL(DEVICE_CHANNEL),
C 1 %VAL(IO_FUNCTION),,,,
C 2 ERROR_MESSAGE,
C 3 %VAL(MESSAGE_LENGTH),,,,)
END IF
RETURN
1000 FORMAT(' ',A)
END
C
C
C
SUBROUTINE FIXUP(NAME,XNAME,SIZE)
INTEGER*4 SIZE,I,COMP,J,X
LOGICAL*1 NAME(SIZE)
LOGICAL*1 XNAME(SIZE)
C
C
C -=- THIS SUBROUTINE DELETES ILLEGAL CHARACTER FROM A PASSED -=-
C -=- STRING, RETURNING THE CALLING STRING CORRECTED -=-
C
C
NAME(SIZE)=' '
C
DO 30 X=1,SIZE-2,1
C
DO 10 I=1,SIZE-1,1
C
C LOOP THRU ALL THE CHARS THE STRING IS MADE UP OF
C
COMP = NAME(I)
C
C -=- GET A CHARACTER TO BE WORKED ON I.E. CHECKED -=-
C
IF ((COMP.LT.48).OR.(COMP.GT.126)) THEN
C
C CHECK FOR SPECIAL CASE CHRS NOW
C
IF(COMP.NE.46) THEN
C ILLEGAL CHARACTER SO REMOVE IT
DO 20 J=I,SIZE-1,1
NAME(J)=NAME(J+1)
20 CONTINUE
END IF
END IF
10 CONTINUE
30 CONTINUE
C
C CONTINUE 'TILL DONE
C
C
C -=- TERMINATE STRING WITH A NULL -=-
C
C
NAME(SIZE)=00
C
C
RETURN
END