PDP-10 Archive: klet10.for from bb-m403a-bk

Trailing-Edge - PDP-10 Archives - bb-m403a-bk - klet10.for

There are no other files named klet10.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='SYS'
	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:')
	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:')
	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