PROGRAM P4READ
C
C THIS PROGRAM READS THE 5 FILES OF THE
C SPECIAL FORMAT P4 COMPILER SOURCE TAPE.
C
C LUN'S USED BY P4READ:
C  1 = MT4:  1600 BPI TAPE (INPUT)
C  2 = SY:   DISK FILE (OUTPUT)
C
C PROGRAMMED BY:
C    BILL HEIDEBRECHT,  28 JAN 78.
C
	LOGICAL*1 BUF(1800), STAT, FNAM(40), BLANK
	INTEGER*4 FNAM4, END4
	DIMENSION ISTAT(2), IPRM(6)
	EQUIVALENCE (ISTAT(1), STAT)
	EQUIVALENCE (FNAM4, FNAM(1))
	PARAMETER MTLUN=1, MTEFN=1, IORLB=512, ISSUC=1, IEEOF=-10, MAXBLK=1800
	DATA END4, BLANK / 4HEND , 32 /
C
C SET UP PARAMETERS.
C
	CALL GETADR(IPRM,BUF)
	IPRM(2) = MAXBLK
	NFILE = 0
C
C
1	TYPE 1900
1900	FORMAT('$FILE NAME OR END: ')
	ACCEPT 1901, FNAM
1901	FORMAT(40A1)
	IF (FNAM4.EQ.END4) GO TO 1000
C
	DO 10 I=1,40
	  IF (FNAM(I).NE.BLANK) GO TO 10
	  FNAM(I) = 0
	  GO TO 40
10	CONTINUE
C
30	TYPE 1902
1902	FORMAT(' ILLEGAL FILE NAME.')
	GO TO 1
C
40	TYPE 1903
1903	FORMAT('$NO. BYTES PER RECORD(I2): ')
	ACCEPT 1904, NBYTRC
1904	FORMAT(I2)
C
	TYPE 1905
1905	FORMAT('$CHR. POS. TO START DELETING TRAILING BLANKS OR 0 (I2): ')
	ACCEPT 1904, IDELET
C
	OPEN (UNIT=2, NAME=FNAM, ERR=30, CARRIAGECONTROL='LIST')
C
	NBLOCK = 0
	NREC   = 0
	NFILE  = NFILE +1
C
C
C BEGINNING OF MAIN READ LOOP.
100	CONTINUE
C READ NEXT BLOCK.
	  CALL WTQIO (IORLB, MTLUN, MTEFN,, ISTAT, IPRM, IDS)
	  IF (IDS.EQ.ISSUC) GO TO 120
	  TYPE 1804, NBLOCK, IDS
1804	  FORMAT(' ERROR READING RECORD',I5,' - IDS =',O7)
	  GO TO 1000
120	  IF (STAT.EQ.IEEOF) GO TO 900
	  IF (STAT.EQ.ISSUC) GO TO 140
	  TYPE 1805, NBLOCK, ISTAT
1805	  FORMAT(' ERROR READING RECORD',I5,' - ISTAT =',2O7)
	  GO TO 900
140	  NBLOCK = NBLOCK +1
	  IF (ISTAT(2).NE.MAXBLK) TYPE 1809, NBLOCK, ISTAT
1809	  FORMAT(' SHORT BLOCK',I5,', ISTAT =',2O7)
C
C UNBLOCK THE RECORD.
C
	  I1 = 1
	  I2 = NBYTRC
	  N = (ISTAT(2)+NBYTRC-1) / NBYTRC
	  DO 300 K=1,N
	    NREC = NREC +1
	    IF (IDELET.EQ.0) GO TO 250
C	      REMOVE TRAILING BLANKS.
	      I2 = I1 + IDELET -1
	      DO 200 I=1,IDELET
	        IF (BUF(I2).NE.BLANK) GO TO 250
	        I2 = I2 -1
200	      CONTINUE
	      IF (I2.LE.I1) I2 = I1
250	    CONTINUE
	    WRITE(2,1806) (BUF(I), I=I1,I2)
	    I1 = I1 + NBYTRC
	    I2 = I1 + NBYTRC -1
1806	    FORMAT(90A1)
300	  CONTINUE
	GO TO 100
C END OF MAIN READ LOOP.
C
C
C END OF FILE.
900	CONTINUE
	TYPE 1990, NFILE, NBLOCK, NREC
1990	FORMAT('  -END OF FILE',I4/'   NBLOCK, NREC =',2I7/)
	CLOSE (UNIT=2, ERR=995)
	GO TO 1
C
995 	TYPE 1991
1991	FORMAT('DISK CLOSE ERROR - ABORT')
C
C TERMINATE PROGRAM.
C
1000	STOP
	END