Trailing-Edge
-
PDP-10 Archives
-
bb-m403a-bk
-
klet20.for
There are no other files named klet20.for in the archive.
PROGRAM KLERR
C ASCII KLERR ENTRY DUMPER (205)
IMPLICIT INTEGER (A-Z)
C PARAMETERS FOR BINARY MASKS OF VARIOUS VALUES
PARAMETER LHMSK="777777000000
PARAMETER RHMSK="000000777777
PARAMETER M9P08="777000000000
PARAMETER M9P17="000777000000
PARAMETER M9P26="000000777000
PARAMETER M9P35="000000000777
PARAMETER M3P02="700000000000
PARAMETER M3P05="070000000000
PARAMETER M3P08="007000000000
PARAMETER M3P11="000700000000
PARAMETER M3P14="000070000000
PARAMETER M3P17="000007000000
PARAMETER M3P20="000000700000
PARAMETER M3P23="000000070000
PARAMETER M3P26="000000007000
PARAMETER M3P29="000000000700
PARAMETER M3P32="000000000070
PARAMETER M3P35="000000000007
COMMON /UNITS/ IUNIT,LUNIT
COMMON /ENTRY/ HDBUFF(0:5),WKBUFF(0:511),EOFM
COMMON /TABLES/ COUNTS(10)
DIMENSION ERRMSG(16)
DOUBLE PRECISION IFILE, IDEV, LFILE, LDEV
C FILE DEFAULTS
IUNIT=20
IDEV='SYSTEM'
IFILE='ERROR.SYS'
LUNIT=30
LDEV='DSK'
LFILE='KLERR.LST'
C INITIALIZE COUNTERS & FLAGS
DO 5 N=1,10
COUNTS(N)=0
5 CONTINUE
EOFM=0
C FIRST GET THE INPUT FILE, IF NOT FOUND, ASK USER
7 TYPE 1001
1001 FORMAT(' INPUT FILE (ESC for default - CR at end):')
OPEN (UNIT=IUNIT, DEVICE=IDEV, ACCESS='SEQIN', MODE='IMAGE',
1 FILE=IFILE, RECORD SIZE=128, DIALOG, ERR=2001)
C NOW OPEN THE LISTING FILE
8 TYPE 1002
1002 FORMAT(' LISTING FILE (ESC for default - CR at end):')
OPEN (UNIT=LUNIT, DEVICE=LDEV, ACCESS='SEQOUT', MODE='ASCII',
1 FILE=LFILE, DIALOG, ERR=2002)
C GET THE NEXT ENTRY AND PROCESS IT
10 CALL GETSEQ
IF (EOFM.EQ.-1) GO TO 900
COUNTS(1)=COUNTS(1)+1
ENTYPE=(HDBUFF(0).AND.M9P08) / 2**27 !GET BITS 0-9 RIGHT JUST.
C GO TO ROUTINE TO HANDLE FRONT END ENTRIES
IF (ENTYPE .EQ. "030) CALL ENT130(2)
IF (ENTYPE .EQ. "130) CALL ENT130(4)
IF (EOFM.LE.-2) GO TO 800
GO TO 10
C PREMATURE END OF PROGRAM
800 TYPE 1004
1004 FORMAT(1X, '? PREMATURE TERMINATION OF PROGRAM DUE TO PREVIOUS',
1 ' ERROR')
IF (EOFM.EQ.-3) STOP
C CLOSE FILES AND OUTPUT RESULTS
900 CALL OUTPUT(TEST) !CLEAN UP ANY LEFTOVER LINE
CLOSE (UNIT=IUNIT, ERR=2005)
910 CLOSE (UNIT=LUNIT, ERR=2006)
920 TYPE 1005, (COUNTS(J), J=1,5)
1005 FORMAT(1X, /I5, ' ENTRIES',
1 / 1X, I5,' - ''030'' ENTRIES', 5X, I5, ' KLERR ENTRIES',
2 / 1X, I5,' - ''130'' ENTRIES', 5X, I5, ' KLERR ENTRIES')
STOP
C ERROR HANDLING ROUTINES
2001 CALL ERRSNS (ERR1, ERR2, ERRMSG)
TYPE 1201, ERR1, ERR2, ERRMSG
1201 FORMAT(' ERROR IN OPENING INPUT FILE!! - ERROR # ', 2I4/1X,16A5)
GO TO 7
2002 CALL ERRSNS (ERR1, ERR2, ERRMSG)
TYPE 1202, ERR1, ERR2, ERRMSG
1202 FORMAT(' ERROR IN OPENING LISTING FILE!! - ERROR # ', 2I4/1X,16A5)
GO TO 8
2005 CALL ERRSNS (ERR1, ERR2, ERRMSG)
TYPE 1205, ERR1, ERR2, ERRMSG
1205 FORMAT(' ERROR IN CLOSING INPUT FILE!! - ERROR # ', 2I4/1X,16A5)
GO TO 910
2006 CALL ERRSNS (ERR1, ERR2, ERRMSG)
TYPE 1206, ERR1, ERR2, ERRMSG
1206 FORMAT(' ERROR IN CLOSING LISTING FILE!! - ERROR # ', 2I4/1X,16A5)
GO TO 920
END
SUBROUTINE ENT130(CNT)
IMPLICIT INTEGER (A-Z)
C*******
C PROCESS 130 ENTRY
C*******
PARAMETER M8P35="000000000377
PARAMETER RHMSK="000000777777
C PARAMETERS FOR INTER BLOCK PROCESSING FLAG:
PARAMETER NEWENT=1 !NEW ENTRY EXPECTED
PARAMETER NEWLIN=2 !START NEW LINE
PARAMETER OLDLIN=3 !CONTINUE CURRENT LINE
PARAMETER RSYNCS=4 !RESYNC SEARCH MODE
PARAMETER RSYNCV=5 !RESYNC VERIFY MODE
PARAMETER TEST=1
PARAMETER ALWAYS=2
COMMON /UNITS/ IUNIT,LUNIT
COMMON /STRING/ LINE(200),CHAR
COMMON /ENTRY/ HDBUFF(0:5),WKBUFF(0:511),EOFM
COMMON /TABLES/ COUNTS(10)
COMMON /POINTR/ OFFSET,BYTCNT,BYTNUM
C CHECK FOR 205 AND COUNT OCCURANCES
IF (COUNTS(CNT) .NE. 0) GO TO 20 !FIRST ENTRY?
FLAG=NEWENT ! YES! - INITIALIZE
OLDBLK=0
CHAR=1
20 COUNTS(CNT) = COUNTS(CNT) + 1 !COUNT F-E ENTRIES
DEVTYP=(WKBUFF(4) .AND. M8P35)
IF (DEVTYP .NE. "205) RETURN !NEW KLERR ENTRY?
COUNTS(CNT+1) = COUNTS(CNT+1) + 1 !COUNT 205 SUB-ENTRIES
C GET OFFSET OF PDP-11 BLOCK AND # OF 8 BIT BYTES
OFFSET=WKBUFF(5) .AND. RHMSK
BYTCNT=WKBUFF(7)
SAVCNT=BYTCNT
BYTNUM=1
IF (BYTCNT .LT. 2) GO TO 1000 !ANY MORE BYTES LEFT?
STATUS=WORD(DUMMY)
IF (BYTCNT .LT. 2) GO TO 1000 !ANY MORE BYTES LEFT?
BLOCK=WORD(DUMMY)
IF (BYTCNT .LT. 2) GO TO 1000 !ANY MORE BYTES LEFT?
OFBLKS=WORD(DUMMY)
D WRITE(LUNIT,9101, ERR=2002) SAVCNT, STATUS, BLOCK, OFBLKS
9101 FORMAT (1X, / ' BYTE COUNT: ', I5, ' STD STATUS: ', O16,
1 ' BLOCK', I5, ' OF', I5, ' BLOCKS')
IF (BYTCNT .GT. 2012) GO TO 2001 !MAXIMUM # OF BYTES?
GO TO (100, 200, 300, 400, 500) FLAG !CONTINUE PROCESSING
C START NEW ENTRY
100 CALL OUTPUT(ALWAYS) !BLANK LINE
OLDBLK=0
C START READING A NEW LINE
200 IF (OLDBLK+1 .NE. BLOCK) GO TO 2003
210 IF (BYTCNT .LT. 2) GO TO 1000 !ANY MORE BYTES LEFT?
LENGTH=WORD(DUMMY)
D WRITE (LUNIT, 9102) BYTCNT, LENGTH
9102 FORMAT(1X, I5, ' BYTES LEFT - - LINE LENGTH =', I5)
250 IF (LENGTH .NE. 0) GO TO 270 !BLANK LINE?
CALL OUTPUT(ALWAYS)
FLAG=NEWLIN
GO TO 210
270 IF (LENGTH .GT. 512) GO TO 2004 !LINE TOO LONG?
FLAG=OLDLIN
GO TO 310
C CONTINUE READING THE CURRENT LINE
300 IF (OLDBLK+1 .NE. BLOCK) GO TO 2003
310 IF (BYTCNT .LT. 1) GO TO 1000 !ANY MORE BYTES LEFT?
LINE(CHAR)=BYTE(DUMMY) !GET NEXT CHARACTER
IF (LINE(CHAR) .NE. 0) CHAR=CHAR+1 !DROP NULL CHARACTERS
LENGTH=LENGTH-1
FLAG=OLDLIN
IF (LENGTH .GT. 0) GO TO 310 !END OF LINE?
CALL OUTPUT(TEST)
FLAG=NEWLIN
GO TO 210
C CODE TO RESYNC WHEN A BLOCK IS MISSING OR A LINE COUNT IS BAD
400 IF (BLOCK .EQ. 1) GO TO 210
410 IF (BYTCNT .LT. 2) GO TO 1000 !ANY MORE BYTES LEFT?
LENGTH=WORD(DUMMY)
IF (LENGTH .GT. 512) GO TO 410 !POSSIBLE LINE COUNT?
FLAG=RSYNCV
GO TO 510
500 IF (BLOCK .EQ. 1) GO TO 210
510 BTCNT=BYTCNT !SAVE POINTERS
BTNUM=BYTNUM
OFSET=OFFSET
IF (BYTCNT .LT. 2) GO TO 1000 !ANY MORE BYTES LEFT?
LOKAHD=WORD(DUMMY) !DO LOOK AHEAD
IF (LOKAHD .LE. 512) GO TO 520 !GOOD CHARACTERS?
BYTCNT=BTCNT !RESTORE POINTERS
BYTNUM=BTNUM
OFFSET=OFSET
GO TO 250
520 LENGTH=LOKAHD
GO TO 250
C GET NEXT BLOCK
1000 IF (STATUS .NE. "140) GO TO 1050 !END OF KLERR FILE?
CALL OUTPUT(TEST)
FLAG=NEWENT
WRITE(LUNIT,9004)
9004 FORMAT(' ****** END OF KLERR ENTRY ******' /)
1050 OLDBLK=BLOCK
RETURN
C ERROR HANDLING ROUTINES
2001 CALL OUTPUT(TEST)
WRITE (LUNIT,1201) BYTCNT
1201 FORMAT(/ ' %BYTE COUNT TOO LARGE:', I5 /)
FLAG=RSYNCS !RESYNC
GO TO 1050
2002 CALL ERRSNS (ERR1, ERR2, ERRMSG)
TYPE 1202, ERR1, ERR2, ERRMSG
1202 FORMAT(' ERROR IN WRITING LISTING FILE!! - ERROR # ', 2I4/1X,16A5)
EOFM=-2
RETURN
2003 CALL OUTPUT(TEST)
NXTBLK=OLDBLK+1
WRITE (LUNIT,1203) BLOCK, NXTBLK
1203 FORMAT(/ ' %FOUND BLOCK #', I5, ' WHEN EXPECTING BLOCK #', I5 /)
FLAG=RSYNCS !RESYNC
GO TO 400 !CHECK FOR BLOCK 1
2004 WRITE (LUNIT,1204) LENGTH, BLOCK
1204 FORMAT(/ ' %LINE LENGTH TOO LARGE (', I5, ') IN BLOCK', I5 /)
FLAG=RSYNCS !RESYNC
GO TO 410
END
INTEGER FUNCTION BYTE(DUMMY)
C GETS THE NEXT PDP-11 BYTE FROM A FRONT-END ENTRY (030 OR 130)
IMPLICIT INTEGER (A-Z)
COMMON /ENTRY/ HDBUFF(0:5),WKBUFF(0:511),EOFM
COMMON /POINTR/ OFFSET,BYTCNT,BYTNUM
BYTCNT=BYTCNT-1
GO TO (100, 200, 300, 400) BYTNUM
100 BYTE=(WKBUFF(OFFSET) .AND. "001774000000) / 2**20
BYTNUM=2
RETURN
200 BYTE=(WKBUFF(OFFSET) .AND. "776000000000) / 2**28
BYTNUM=3
RETURN
300 BYTE=(WKBUFF(OFFSET) .AND. "000000007760) / 2**4
BYTNUM=4
RETURN
400 BYTE=(WKBUFF(OFFSET) .AND. "000003770000) / 2**12
BYTNUM=1
OFFSET=OFFSET+1
RETURN
END
INTEGER FUNCTION WORD(DUMMY)
C GETS THE NEXT PDP-11 WORD FROM A FRONT-END ENTRY (030 OR 130)
IMPLICIT INTEGER (A-Z)
COMMON /ENTRY/ HDBUFF(0:5),WKBUFF(0:511),EOFM
COMMON /POINTR/ OFFSET,BYTCNT,BYTNUM
GO TO (100, 200, 300, 400) BYTNUM
400 BYTCNT=BYTCNT-1 !ALIGN ON WORD BOUNDARY
OFFSET=OFFSET+1
100 WORD=(WKBUFF(OFFSET) .AND. "777774000000) / 2**20
BYTCNT=BYTCNT-2
BYTNUM=3
RETURN
200 BYTCNT=BYTCNT-1 !ALIGN ON WORD BOUNDARY
300 WORD=(WKBUFF(OFFSET) .AND. "000003777760) / 2**4
BYTCNT=BYTCNT-2
OFFSET=OFFSET+1
BYTNUM=1
RETURN
END
SUBROUTINE OUTPUT(ARG)
C*******
C OUTPUTS LINE OF TEXT
C*******
IMPLICIT INTEGER (A-Z)
COMMON /UNITS/ IUNIT,LUNIT
COMMON /STRING/ LINE(200),CHAR
C VALUES FOR 'ARG'
C
C 1 - TEST FOR CHARACTERS IN LINE
C 2 - OUTPUT BLANK LINE
GO TO (100, 200) ARG
100 IF (CHAR .GT. 1) WRITE(LUNIT,9000) (LINE(K), K=1,CHAR-1)
GO TO 500
200 WRITE (LUNIT,9000)
GO TO 500
500 CHAR=1
RETURN
9000 FORMAT(1X, 200R1)
END
SUBROUTINE GETSEQ
C*******
C GETS THE NEXT ENTRY INTO HDBUFF AND WKBUFF
C*******
IMPLICIT INTEGER (A-Z)
PARAMETER M9P08="777000000000
PARAMETER M9P35="000000000777
PARAMETER M3P26="000000007000
COMMON /FILBUF/ INBUFF(128),INDEX,IEND,SYNCWD
COMMON /ENTRY/ HDBUFF(0:5),WKBUFF(0:511),EOFM
C CLEAR OLD HEADER AND WORK BUFFER
DO 10 I=0,HDLNTH
HDBUFF(I)=0
10 CONTINUE
DO 20 I=0,WKLNTH
WKBUFF(I)=0
20 CONTINUE
25 IF (INDEX.EQ.0) CALL GETSBL !GET FIRST BLOCK OF THE FILE
30 HDRWD0 = INBUFF(INDEX) !GET HEADER WD0
ENTYPE=(HDRWD0.AND.M9P08) / 2**27 !GET BITS 0-9 RIGHT JUST.
IF(ENTYPE.EQ.-1) INDEX =0 !DAEMON EOF-TRY NEXT BLOCK
IF((ENTYPE.EQ.0).AND.(IEND.EQ.0)) INDEX=0 !A ZERO ENTRY?
IF(INDEX.EQ.0) GO TO 25 !GET NEXT BLOCK
HDLNTH=(HDRWD0.AND.M3P26) / 2**9 !LENGTH OF HEADER
WKLNTH=(HDRWD0.AND.M9P35) !LENGTH OF BODY
! PROBLEMS IN INPUT FILE, TRY TO RE-SYNC IN NEXT BLOCK
IF((IEND.EQ.0).AND.(HDLNTH.NE.0).AND.(WKLNTH.NE.0)) GO TO 35
!VALID LENGTHS
34 IF(IEND.EQ.-1) GO TO 60 !END OF FILE ,SET EOFM AND RETURN
CALL GETSBL
IF(SYNCWD.EQ.0)GO TO 34
INDEX=SYNCWD + 1
GO TO 30
!TRY AGAIN
35 DO 40 I=0,HDLNTH-1
HDBUFF(I)=INBUFF(INDEX) !FILL HEADER BUFFER
INDEX = INDEX + 1
IF(INDEX.EQ.129) CALL GETSBL !GET NEXT BLOCK OF FILE
40 CONTINUE
DO 50 I=0,WKLNTH-1
WKBUFF(I)=INBUFF(INDEX) !FILL BODY BUFFER
INDEX = INDEX + 1
IF(INDEX.EQ.129) CALL GETSBL !GET NEXT BLOCK OF FILE
50 CONTINUE
C**** ALL DONE SO RETURN THIS ENTRY
C**** FIRST CHECK FOR EOF SEEN BY GETSBL AND NO DATE IN THIS HEADER
60 IF((IEND.EQ.-1).AND.(HDBUFF(1).EQ.0)) EOFM=-1 !IF EOF,SAY SO
IF(EOFM.EQ.-1) IEND=0 !REAL "NO MORE ENTRIES" SO CLEAR IEND
!TO SETUP FOR NEXT FILE IF ANY.
RETURN
END
SUBROUTINE GETSBL
C*******
C GETS THE NEXT BLOCK OF THE FILE OR ELSE RETURNS EOF
C*******
IMPLICIT INTEGER (A-Z)
COMMON /UNITS/ IUNIT,LUNIT
COMMON /FILBUF/ INBUFF(128),INDEX,IEND,SYNCWD
DIMENSION ERRMSG(16)
READ (IUNIT, END=10, ERR=2003) INBUFF !GET THE NEXT BLOCK
IF (INBUFF(1) .EQ. 0) GO TO 10 !EOF???
GO TO 15 !SKIP OVER SETTING IEND
10 IEND=-1
15 INDEX=1
SYNCWD=(INBUFF(1).AND."777777) !FIND OFFSET TO START OF FIRST ENTRY
INDEX=2
RETURN
C HANDLE ERRORS READING INPUT FILE
2003 CALL ERRSNS (ERR1, ERR2, ERRMSG)
TYPE 1203, ERR1, ERR2, ERRMSG
1203 FORMAT(' ERROR IN READING INPUT FILE!! - ERROR # ', 2I4/1X,16A5)
STOP
END