C**PALASM24**PALASM24**PALASM24**PALASM24**PALASM24**PALASM24**
C
C P A L A S M 2 4 - TRANSLATES SYMBOLIC EQUATIONS INTO PAL OBJECT
C			    	CODE FORMATTED FOR DIRECT INPUT TO STANDARD
C			    	PROM PROGRAMMERS.
C
C INPUT: PAL DESIGN SPECIFICATION ASSIGNED
C 		 TO RPD(1). OPERATION CODES ARE
C 		 ASSIGNED TO ROP(5).
C
C OUTPUT: ECHO,SIMULATION, AND FUSE PATTERN
C 		  ARE ASSIGNED TO POF(6). HEX AND BINARY
C		  FORMATS ARE ASSIGNED TO PDF(6). PROMPTS
C		  AND ERROR MESSAGES ARE ASSIGNED TO PMS(6).
C
C PART NUMBER: THE PAL PART NUMBER MUST APPEAR IN
C			   COLUMN ONE OF LINE ONE.
C
C PIN LIST: 24 SYMBOLIC PIN NAMES MUST APPEAR STARTING
C			ON LINE FIVE.
C
C EQUATIONS: STARTING FIRST LINE AFTER THE PIN LIST IN
C			 THE FOLLOWING FORMS:
C
C			 A = B * C + D ; A EQUALS B AND C OR D
C
C			 A := B * C + D ; A IS REPLACED AFTER LOW TO
C							; HIGH TRANSISTION OF THE CLOCK
C							; IF B AND C OR D
C
C			 IF( A * B ) C = D + E ; IF A AND B ARE TRUE THEN
C								   ; C EQUALS D OR E
C
C ALL CHARACTERS FOLLOWING THE ';' ARE IGNORED UNTIL NEXT LINE
C
C BLANKS ARE IGNORED
C
C OPERATORS: (IN HIERARCHY OF EVALUATION )
C
C			 ;		COMMENT FOLLOWS
C			 /		COMPLEMENT
C			 *		AND, PRODUCT
C			 +		OR, SUM
C			 :+:	EXCLUSIVE OR
C			 ( )	CONDITIONAL THREE STATE
C			 = 		EQUALITY
C			 := 	REPLACE BY ( AFTER CLOCK )
C
C FUNCTION TABLE: L, H, X, Z, C ARE VALID FUNCTION
C				  TABLE ENTRIES
C
C SUBROUTINES: INITLZ, GETSYM, INCR, MATCH, IXLATE,
C			   ECHO, PINOUT, PLOT, HEX, TWEEK, BINR,
C			   SLIP, FANTOM, IODC2, IODC4, TEST
C
C REV LEVEL: 07/20/81
C
C FINE PRINT: MONOLITHIC MEMORIES TAKES NO RESPONSIBILITY
C			  FOR THE OPERATION OR MAINTENANCE OF THIS PROGRAM.
C			  THE SOURCE CODE AS PRINTED HERE PRODUCED THE OBJECT 
C			  CODE OF THE EXAMPLES IN THE APPLICATIONS SECTION
C			  ON A VAX/VMS COMPUTER AND A NATIONAL CSS IBM
C			  SYSTEM/370 FORTRAN IV(G).
C
C****************************************************************
C
C Compile and Link using Absoft's AC/FORTRAN Ver. 2.3
C
C F77 -deksu palasm.for
C
C F77l -y -m -o apalasm24 palasm args.sub errmsg.sub
C
C MY USAGE FOR THE PROGRAM: apalasm24 filename
C
C INPUT: filename.pal
C 
C OUTPUT: The following files are generated from the following
C		  optional OPERATION CODES.
C
C			E = filename.src
C			O = filename.pins
C			T = filename.sim
C			P = filename.plt
C			B = filename.brf
C			D = filename.jed
C
C		  The other outputs were removed from the menu only
C		  because they are for paper tape type devices.

C****************************************************************
C
      PROGRAM PALASM
C
C****************************************************************
C
C
C     MAIN PROGRAM
C
      IMPLICIT	NONE
      INTEGER	IPAL(3),INAME(5),REST(72),PATNUM(80),TITLE(80),
     .		COMP(80),ISYM(8,24),IBUF(8,24),IPAGE(80,200),
     .		IFUNCT,IDESC,IEND,PMS,POF,PDF,E,O,T,P,B,D,ILE,ILL,
     .		H,S,L,N,Q,U,F,BB,CC,DD,EE,FF,II,NN,OO,PP,RR,IMATCH,
     .		SS,TT,UU,AA,LL,RPD,ROC,LEN,J,I,ITYPE,IC,IL,IBLOW,
     .		I88PRO,I8PRO,C,IPROD,IINPUT,IOP,ILERR
      LOGICAL	LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR,
     .		LFIRST,LMATCH,LFUSES(40,80),LPHASE(24),LBUF(24),
     .		LPROD(80),LSAME,LACT,LOPERR,LHEAD
      CHARACTER cmdline*20,filename*25
      COMMON	LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
      COMMON	/PGE/ IPAGE(80,200)
      COMMON      /FTEST/ IFUNCT,IDESC,IEND
      COMMON      /LUNIT/ PMS,POF,PDF
      DATA E/'E'/,O/'O'/,T/'T'/,P/'P'/,B/'B'/,D/'D'/,
     .     H/'H'/,S/'S'/,L/'L'/,N/'N'/,Q/'Q'/,U/'U'/,F/'F'/
      DATA BB/'B'/,CC/'C'/,DD/'D'/,EE/'E'/,FF/'F'/,II/'I'/,NN/'N'/,
     .     OO/'O'/,PP/'P'/,RR/'R'/,SS/'S'/,TT/'T'/,UU/'U'/,AA/'A'/,
     .     LL/'L'/
C
C
      RPD = 2 
      ROC = 5
      POF = 9
      PDF = 9
      PMS = 9
      IFUNCT = 0
      IDESC = 0
C
      LSAME = .FALSE.
      LACT = .FALSE.
      LOPERR = .FALSE.
      LHEAD = .TRUE.
C
C read in the first 4 lines of the pal design spec
C
C
C read the command line arg
C 
	  Call args(cmdline)
      filename = cmdline
	  len = index(cmdline,' ')
	  filename(len:) = '.pal'
      PRINT*,'This Program is in the Public Domain'
      PRINT*,'Reading file ',filename
C
	  OPEN(UNIT=2,FILE=filename,STATUS='old')
      READ(RPD,10) IPAL,INAME,REST,PATNUM,TITLE,COMP
   10 FORMAT(3A1,5A1,72A1,/,80A1,/,80A1,/,80A1)
C
C read in the pin list (line 5) through the end of the pal design
C specification
C
      DO (J=1,200)
      READ(RPD,11,END=16) (IPAGE(I,J),I=1,80)
   11 FORMAT(80A1)
C
C check for 'FUNCTION TABLE'and save the line number
C
      IF( IFUNCT.EQ.0 .AND. IPAGE(1,J).EQ.FF.AND.
     .    IPAGE(2,J).EQ.UU.AND.IPAGE(3,J).EQ.NN.AND.
     .    IPAGE(4,J).EQ.CC.AND.IPAGE(5,J).EQ.TT.AND.
     .    IPAGE(6,J).EQ.II.AND.IPAGE(7,J).EQ.OO.AND.
     .    IPAGE(8,J).EQ.NN.AND.IPAGE(10,J).EQ.TT.AND.
     .    IPAGE(11,J).EQ.AA.AND.IPAGE(12,J).EQ.BB.AND.
     .    IPAGE(13,J).EQ.LL.AND.IPAGE(14,J).EQ.EE)IFUNCT=J

C
C check for 'DESCRIPTION' and save the line number
C
      IF( IDESC.EQ.0 .AND. IPAGE(1,J).EQ.DD.AND.
     .    IPAGE(2,J).EQ.EE.AND.IPAGE(3,J).EQ.SS.AND.
     .    IPAGE(4,J).EQ.CC.AND.IPAGE(5,J).EQ.RR.AND.
     .    IPAGE(6,J).EQ.II.AND.IPAGE(7,J).EQ.PP.AND.
     .    IPAGE(8,J).EQ.TT.AND.IPAGE(9,J).EQ.II.AND.
     .    IPAGE(10,J).EQ.OO.AND.IPAGE(11,J).EQ.NN) IDESC=J
      REPEAT
C
C save the last line number of the pal design spec
C
   16 IEND = J-1
      CLOSE(2)
      CALL INITLZ(INAME,ITYPE,LFUSES,IC,IL,IBLOW,LPROD)
C
C print error message for invalid pal part type
C
      IF(ITYPE.NE.0) GO TO 17
      WRITE(PMS,18) IPAL,INAME
   18 FORMAT(/,' PAL PART TYPE "',3A1,5A1,'" IS INCORRECT')
      STOP
C
C get 24 pin names
C
   17 DO (J=1,24)
   		CALL GETSYM(LPHASE,ISYM,J,IC,IL)
      REPEAT
      IF(.NOT.(LEQUAL.OR.LLEFT.OR.LAND.OR.LOR.OR.LRIGHT)) GO TO 24
      WRITE(PMS,23)
   23 FORMAT(/,' LESS THAN 24 PIN NAMES IN THE PIN LIST')
      STOP
   24 ILE = IL
   25 CALL GETSYM(LBUF,IBUF,1,IC,IL)
   28 IF(.NOT.LEQUAL) GO TO 25
   	  ILL = IL
      CALL MATCH(IMATCH,IBUF,ISYM)
      IF(IMATCH.EQ.0) GO TO 100
C
C check for valid polarity (active low)
C
      LSAME = ((LPHASE(IMATCH)).AND.(LBUF(1)).OR.
     .        (.NOT.LPHASE(IMATCH)).AND.(.NOT.LBUF(1)))
      IF(ITYPE.NE.6.AND.(LSAME)) LACT = .TRUE.
C
C check for valid output pin
C
   29 IF((ITYPE.EQ.1.OR.ITYPE.EQ.7.OR.ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.
     .   ITYPE.EQ.10).AND.(IMATCH.LT.14.OR.IMATCH.GT.23))
     .   LOPERR = .TRUE.
      IF((ITYPE.EQ.2.OR.ITYPE.EQ.11.OR.ITYPE.EQ.12.OR.ITYPE.EQ.13
     .   .OR.ITYPE.EQ.14).AND.(IMATCH.LT.15.OR.IMATCH.GT.22))
     .   LOPERR = .TRUE.
      IF(ITYPE.EQ.3.AND.(IMATCH.LT.16.OR.IMATCH.GT.21))
     .   LOPERR = .TRUE.
      IF(ITYPE.EQ.4.AND.(IMATCH.LT.17.OR.IMATCH.GT.20))
     .   LOPERR = .TRUE.
      IF((ITYPE.EQ.5.OR.ITYPE.EQ.6).AND.(IMATCH.LT.18.OR.IMATCH.GT.19))
     .   LOPERR = .TRUE.
      IF((LACT).OR.(LOPERR)) GO TO 100
      I88PRO = (23-IMATCH)*8+1
C
C start PAL20C1 on product line 33
C
      IF(INAME(3).EQ.C) I88PRO = 33
      IC = 0
   30 CALL INCR(IC,IL)
   	  IF(.NOT.(LEQUAL.OR.LLEFT)) GO TO 30
	  LPROD(I88PRO) = .TRUE.
      IF(.NOT.LLEFT) CALL SLIP(LFUSES,I88PRO,ITYPE,IBLOW)
      DO(I8PRO = 1,16)
			IPROD = I88PRO+I8PRO-1
			LPROD(IPROD) = .TRUE.
			LFIRST = .TRUE.
   50 		ILL = IL
   			CALL GETSYM (LBUF,IBUF,1,IC,IL)
			CALL MATCH(IMATCH,IBUF,ISYM)
			IF(IMATCH.EQ.0) GO TO 100
			IF(IMATCH.EQ.12) GO TO 64
			IF(.NOT.LFIRST) GO TO 58
				LFIRST = .FALSE.
				DO (I=1,40)
					IBLOW = IBLOW+1
					LFUSES(I,IPROD) = .TRUE.
                REPEAT
   58 CALL IXLATE(IINPUT,LPHASE,IMATCH,LBUF,ITYPE)
      IF(IINPUT.LE.0) GO TO 60
      IBLOW = IBLOW-1
      LFUSES(IINPUT,IPROD) = .FALSE.
      CALL PLOT(LBUF,IBUF,LFUSES,IPROD,TITLE,.FALSE.,ITYPE,
     . 		    LPROD,IOP,IBLOW,I88PRO,I8PRO,cmdline)
   60 IF(LAND) GO TO 50
   64 IF(.NOT.LRIGHT) GO TO 68
   66 CALL INCR(IC,IL)
      IF(.NOT.LEQUAL) GO TO 66
   68 IF(.NOT.(LOR.OR.LEQUAL)) GO TO 74
      REPEAT
   74 ILL = IL
      CALL GETSYM(LBUF,IBUF,1,IC,IL)
      IF(LLEFT.OR.LEQUAL) GO TO 28
  100 IF(ILL.EQ.IFUNCT.OR.ILL.EQ.IDESC.OR.ILL.EQ.IEND) GO TO 104
C
C error message for unrecognizable symbol
C
      ILERR = ILL+4
      WRITE(PMS,101) (IBUF(I,1),I=1,8),ILERR,(IPAGE(I,ILL),I=1,80)
  101 FORMAT(/,' ERROR SYMBOL = ',8A1,' IN LINE NUMBER ',I3,
     .       /, ' ',80A1)
C
C error message for active high/low errors
C
      IF((LACT).AND.(.NOT.LOPERR)) WRITE(PMS,102) IPAL,INAME
  102 FORMAT(' OUTPUT MUST BE INVERTED SINCE ',3A1,5A1,
     .        ' IS AN ACTIVE LOW DEVICE')
C
C error message for invalid output pin
C
      IF((LOPERR).AND.IMATCH.NE.0) WRITE(PMS,103)IMATCH,IPAL,INAME
  103 FORMAT(' THIS PIN, NUMBER ',I2,' IS AN INVALID OUTPUT PIN',
     .       ' FOR ',3A1,5A1)
      STOP
  104 CALL TWEEK(ITYPE,LFUSES)
C
C print optional header
C
      PRINT*,'APALASM24 by Bob Metzler                   Version 1.00'
  105 IF(LHEAD) WRITE(PMS,106)
  106 FORMAT(/,' THIS PALASM AIDS THE USER IN THE DESIGN AND'
     . 	' PROGRAMMING OF THE',/,' SERIES 24 PAL FAMILY. THE',
     .	' FOLLOWING OPTIONS ARE PROVIDED:',
     . 	//,'     ECHO(E)      - PRINTS THE PAL DESIGN',
     .	' SPECIFICATION',
     . 	/,'     PIN OUT(O)   - PRINTS THE PIN OUT OF THE PAL',
     . 	/,'     SIMULATE(T)  - EXERCISES THE FUNCTION TABLE',
     .	' VECTORS IN LOGIC',/,'                    EQUATIONS',
     .      ' AND GENERATES TEST VECTORS',
     . 	/,'     PLOT(P)      - PRINTS THE ENTIRE FUSE PLOT',
     . 	/,'     BRIEF(B)     - PRINTS ONLY THE USED PRODUCT LINES',
     .      ' OF THE FUSE PLOT',/,'                    PHANTOM',
     .      ' FUSES ARE OMITTED'
     . 	/,'     DATA I/O(D)  - GENERATES FUSE OUTPUT FOR DATA I/O',
     .	' PROGRAMMERS',
     . 	/,'     QUIT(Q)      - EXITS PALASM')
C
C    . 	/,'     HEX(H)       - GENERATES HEX OUTPUT FOR PAPER TAPE',
C    . 	/,'     SHORT(S)     - GENERATES HEX OUTPUT FOR PAPER TAPE',
C    . 	/,'     BHLF(L)      - GENERATES BHLF OUTPUT FOR PAPER TAPE',
C    . 	/,'     BNPF(N)      - GENERATES BNPF OUTPUT FOR PAPER TAPE',
C
  107 WRITE(PMS,108)
  108 FORMAT(/,' OPERATION CODES:')
      WRITE(PMS,109)
  109 FORMAT(/,' E=ECHO INPUT O=PIN OUT T=SIMULATE P=PLOT B=BRIEF',
     .      /,' D=DATA I/O Q=QUIT')
C
C    .      /,' D=DATA I/O H=HEX S=SHORT L=BHLF N=BNPF Q=QUIT')
C
	  WRITE(PMS,110)
  110 FORMAT(/,' ENTER OPERATION CODE:')
  	  READ(*,120) IOP
  120 FORMAT(A1)
C     call IODC2
	  IF(IOP.EQ.E) CALL ECHO(IPAL,INAME,REST,PATNUM,TITLE,COMP,
     .                       cmdline)
	  IF(IOP.EQ.O) CALL PINOUT(IPAL,INAME,TITLE,cmdline)
	  IF(IOP.EQ.T) CALL TEST(LPHASE,LBUF,TITLE,IC,IL,
     .                       ILE,ISYM,IBUF,ITYPE,cmdline)
	  IF(IOP.EQ.P) CALL PLOT(LBUF,IBUF,LFUSES,IPROD,TITLE,
     .                      .TRUE.,ITYPE,LPROD,IOP,IBLOW,I88PRO,
     .                      I8PRO,cmdline)
	  IF(IOP.EQ.B) CALL PLOT(LBUF,IBUF,LFUSES,IPROD,TITLE,
     .                      .TRUE.,ITYPE,LPROD,IOP,IBLOW,I88PRO,
     .                      I8PRO,cmdline)
	  IF(IOP.EQ.D) CALL PLOT(LBUF,IBUF,LFUSES,IPROD,TITLE,
     .                      .TRUE.,ITYPE,LPROD,IOP,IBLOW,I88PRO,
     .                      I8PRO,cmdline)
	  IF(IOP.EQ.H) CALL HEX(LFUSES,H,cmdline)
	  IF(IOP.EQ.S) CALL HEX(LFUSES,S,cmdline)
	  IF(IOP.EQ.L) CALL BINR(LFUSES,H,L)
	  IF(IOP.EQ.N) CALL BINR(LFUSES,P,N)
C     call IODC4
	  IF(IOP.NE.Q) GO TO 107
	  STOP
	  END
C
C ********************************************************
C
      SUBROUTINE INITLZ(INAME,ITYPE,LFUSES,IC,IL,IBLOW,LPROD)
C
C This subroutine initializes variables and matches pal part
C number with ITYPE
C
      IMPLICIT NONE
      INTEGER INAME(5),INFO(6,14),ITYPE,IC,IL,IBLOW,IPAGE,I,J
      LOGICAL LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,
     .        LFUSES(40,80),LMATCH,LXOR,LPROD(80)
	  COMMON LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
	  COMMON /PGE/ IPAGE(80,200)
	  DATA INFO/
     . '1','2','L','1','0',1,
     . '1','4','L','8',' ',2,
     . '1','6','L','6',' ',3,
     . '1','8','L','4',' ',4,
     . '2','0','L','2',' ',5,
     . '2','0','C','1',' ',6,
     . '2','0','L','1','0',7,
     . '2','0','X','1','0',8,
     . '2','0','X','8',' ',9,
     . '2','0','X','4',' ',10,
     . '2','0','L','8',' ',11,
     . '2','0','R','8',' ',12,
     . '2','0','R','6',' ',13,
     . '2','0','R','4',' ',14/
C
C initialize LFUSES array (fuse array)
C
      DO (J=1,80)
			DO (I=1,40)
				LFUSES(I,J)=.FALSE.
			REPEAT
	  		LPROD(J)=.FALSE.
      REPEAT
C
C initialize IBLOW (number of fuses blown)
C
      IBLOW = 0
C
C initialize IC and IL (column and line pointers)
C
      IC = 0
      IL = 1
C
C initialize ITYPE (pal part type)
C
      ITYPE = 0
C
C ITYPE is assigned the following values for each of the pal types
C PAL12L10 = 1 PAL14L8 = 2 PAL16L6 = 3 PAL18L4 = 4
C PAL20L2 = 5 PAL20C1 = 6 PAL20L10 = 7 PAL20X10 =8 
C PAL20X8 = 9 PAL20X4 = 10 PAL20L8 = 11 PAL20R8 =12
C PAL20R6 = 13 PAL20R4 = 14
C
      DO (J=1,14)
		LMATCH =.TRUE.
		DO (I=1,4)
			IF(INAME(I).NE.INFO(I,J)) LMATCH = .FALSE.
		REPEAT
		IF(LMATCH) ITYPE = INFO(6,J)
		IF(LMATCH) go to 50
      REPEAT
      IF(ITYPE.EQ.0) RETURN
   50 CALL INCR(IC,IL)
      RETURN
      END
C
C ********************************************************
C
      SUBROUTINE GETSYM(LPHASE,ISYM,J,IC,IL)
C
C This routine gets the PIN NAME, /if complement logic, and
C the following operation symbol if any
C
      IMPLICIT NONE
	  INTEGER ISYM(8,24),IPAGE(80,200),IBLANK,IC,IL,I,J
      LOGICAL LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,
     .        LXOR,LPHASE(24)
	  COMMON LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
	  COMMON /PGE/ IPAGE(80,200)
	  DATA IBLANK/' '/
	  IF( .NOT.(LLEFT.OR.LAND.OR.LOR.OR.LEQUAL.OR.LRIGHT)) GO TO 10
	  CALL INCR(IC,IL)
   10 LPHASE(J) = (.NOT.LSLASH)
      IF(LPHASE(J)) GO TO 15
	  CALL INCR(IC,IL)
   15 DO (I=1,8)
      	ISYM(I,J) = IBLANK
	  REPEAT
   25 DO (I=1,7)
      	ISYM(I,J) = ISYM(I+1,J)
	  REPEAT
	  ISYM(8,J) = IPAGE(IC,IL)
	  CALL INCR(IC,IL)
	  IF( LLEFT.OR.LBLANK.OR.LAND.OR.LOR.OR.LRIGHT.OR.LEQUAL) RETURN
	  GO TO 25
	  END
C
C ********************************************************
C
      SUBROUTINE INCR(IC,IL)
C
C This subroutine increments column and line pointers
C blanks and characters after ';' are ignored
C
      IMPLICIT NONE
	  INTEGER ISYM(8,24),IPAGE(80,200),IBLANK,IC,IL,PMS,
     .        POF,PDF,ILEFT,IAND,IOR,COMMENT,ISLASH,IEQUAL,
     .        IRIGHT,ICOLON
      LOGICAL LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,
     .        LXOR,LXOR1
	  COMMON LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
	  COMMON /PGE/ IPAGE(80,200)
	  COMMON /LUNIT/ PMS,POF,PDF
      DATA IBLANK/' '/,ILEFT/'('/,IAND/'*'/,IOR/'+'/,COMMENT/';'/,
     .     ISLASH/'/'/,IEQUAL/'='/,IRIGHT/')'/,ICOLON/':'/
	  LBLANK = .FALSE.
	  LXOR = .FALSE.
	  LXOR1 = .FALSE.
   10 IC = IC+1
      IF(IC.LE.79.AND.IPAGE(IC,IL).NE.COMMENT) GO TO 30
      IL = IL+1
	  IF(IL.LE.200) GO TO 20
	  WRITE(PMS,15)
   15 FORMAT(/,' SOURCE FILE EXCEEDS 200 LINES')
      STOP
   20 IC = 0
      GO TO 10
   30 IF(IPAGE(IC,IL).NE.IBLANK) GO TO 31
      LBLANK = .TRUE.
	  GO TO 10
   31 IF(IPAGE(IC,IL).NE.ICOLON) GO TO 33
	  IF(LXOR) GO TO 32
      LXOR1 = .TRUE.
	  GO TO 10
   32 LOR = .TRUE.
      RETURN
   33 IF( .NOT.(IPAGE(IC,IL).EQ.IOR.AND.(LXOR1)) ) GO TO 34
      LXOR = .TRUE.
	  GO TO 10
   34 LLEFT = (IPAGE(IC,IL).EQ.ILEFT)
      LAND = (IPAGE(IC,IL).EQ.IAND)
      LOR = (IPAGE(IC,IL).EQ.IOR)
      LSLASH = (IPAGE(IC,IL).EQ.ISLASH)
      LEQUAL = (IPAGE(IC,IL).EQ.IEQUAL)
      LRIGHT = (IPAGE(IC,IL).EQ.IRIGHT)
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE MATCH(IMATCH,IBUF,ISYM)
C
C This subroutine finds a match between the pin name in the equation
C and the pin name in the pin list or function table pin list
C
      IMPLICIT NONE
	  INTEGER IBUF(8,24),ISYM(8,24),IMATCH,I,J
      LOGICAL LMATCH
      IMATCH = 0
      DO (J=1,24)
	  	LMATCH = .TRUE.
	  	DO (I=1,8)
	  		LMATCH = LMATCH.AND.(IBUF(I,1).EQ.ISYM(I,J))
	  	REPEAT
	  	IF(LMATCH) IMATCH = J
	  REPEAT
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE IXLATE(IINPUT,LPHASE,IMATCH,LBUF,ITYPE)
C
C This subroutine finds a match between input pin number and
C the input line number for a specific pal, add 1 the the input
C line number if the pin is a complement
C
	  IMPLICIT NONE
	  INTEGER ITABLE(24,14),IINPUT,IMATCH,ITYPE,IBUBL
	  LOGICAL LPHASE(24),LBUF(24)
	  DATA    ITABLE/
     .3,1,5,9,13,17,21,25,29,33,37,0,39,0,0,0,0,0,0,0,0,0,0,0,
     .3,1,5,9,13,17,21,25,29,33,37,0,39,35,0,0,0,0,0,0,0,0,7,0,
     .3,1,5,9,13,17,21,25,29,33,37,0,39,35,31,0,0,0,0,0,0,11,7,0,
     .3,1,5,9,13,17,21,25,29,33,37,0,39,35,31,27,0,0,0,0,15,11,7,0,
     .3,1,5,9,13,17,21,25,29,33,37,0,39,35,31,27,23,0,0,19,15,11,7,0,
     .3,1,5,9,13,17,21,25,29,33,37,0,39,35,31,27,23,0,0,19,15,11,7,0,
     .3,1,5,9,13,17,21,25,29,33,37,0,39,0,35,31,27,23,19,15,11,7,0,0,
     .0,1,5,9,13,17,21,25,29,33,37,0,0,39,35,31,27,23,19,15,11,7,3,0,
     .0,1,5,9,13,17,21,25,29,33,37,0,0,39,35,31,27,23,19,15,11,7,3,0,
     .0,1,5,9,13,17,21,25,29,33,37,0,0,39,35,31,27,23,19,15,11,7,3,0,
     .3,1,5,9,13,17,21,25,29,33,37,0,39,35,0,31,27,23,19,15,11,0,7,0,
     .0,1,5,9,13,17,21,25,29,33,37,0,0,39,35,31,27,23,19,15,11,7,3,0,
     .0,1,5,9,13,17,21,25,29,33,37,0,0,39,35,31,27,23,19,15,11,7,3,0,
     .0,1,5,9,13,17,21,25,29,33,37,0,0,39,35,31,27,23,19,15,11,7,3,0/
	  IBUBL=0
	  IF( (( LPHASE(IMATCH)).AND.(.NOT.LBUF(1))).OR.
     .    (( .NOT.LPHASE(IMATCH)).AND.(LBUF(1))) ) IBUBL=1
	  IINPUT=ITABLE(IMATCH,ITYPE)+IBUBL
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE ECHO(IPAL,INAME,REST,PATNUM,TITLE,COMP,cmdline)
C 
C this subroutine prints the pal design specification input file
C
	  IMPLICIT NONE
	  INTEGER IPAL(3),INAME(5),REST(72),PATNUM(80),TITLE(80),
     .        COMP(80),IPAGE(80,200),IFUNCT,IDESC,IEND,
     .        PMS,POF,PDF,LEN,I,J
      CHARACTER cmdline*20,echoname*25
	  COMMON /PGE/ IPAGE(80,200)
	  COMMON /LUNIT/ PMS,POF,PDF
	  COMMON /FTEST/ IFUNCT,IDESC,IEND
C
      echoname = cmdline
	  len = index(cmdline,' ')
	  echoname(len:) = '.src'
      PRINT*,'Writing file ',echoname
	  OPEN(UNIT=7,FILE=echoname,STATUS='new')
C
	  WRITE(7,10) IPAL,INAME,REST,PATNUM,TITLE,COMP
  10  FORMAT(/,' ',3A1,5A1,72A1,/,' ',80A1,/,' ',80A1)
	  DO (J=1,IEND)
	  	WRITE(7,20) (IPAGE(I,J),I=1,80)
  20    FORMAT(' ',80A1)
	  REPEAT
      CLOSE(7)
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE PINOUT(IPAL,INAME,TITLE,cmdline)
C
C this subroutine prints the pin out of the pal
C
	  IMPLICIT NONE
	  INTEGER IPAL(3),INAME(5),TITLE(80),PIN(8,24),IIN(8,2),
     .        IPAGE(80,200),IBLANK,ISTAR,LEN,PMS,POF,PDF,
     .        I,J,IL,IC,II,JJ
      CHARACTER cmdline*20,pinname*25
	  COMMON /PGE/ IPAGE(80,200)
	  COMMON /LUNIT/ PMS,POF,PDF
      DATA IBLANK/' '/,ISTAR/'*'/
C
      pinname = cmdline
	  len = index(cmdline,' ')
	  pinname(len:) = '.pins'
      PRINT*,'Writing file ',pinname
	  OPEN(UNIT=8,FILE=pinname,STATUS='new')
C
	  DO (J=1,24)
	  	DO (I=1,8)
			PIN(I,J)=IBLANK
		REPEAT
	  REPEAT
	  DO (J=1,2)
	  	DO (I=1,8)
			IIN(I,J)=IBLANK
		REPEAT
	  REPEAT
	  IIN(2,1)=IPAL(1)
	  IIN(4,1)=IPAL(2)
	  IIN(6,1)=IPAL(3)
	  IIN(1,2)=INAME(1)
	  IIN(3,2)=INAME(2)
	  IIN(5,2)=INAME(3)
	  IIN(7,2)=INAME(4)
	  IIN(8,2)=INAME(5)
	  J=0
	  IL=0
  30  IC=0
      IL=IL+1
  35  IC=IC+1
  40  IF( IC.GT.80) GO TO 30
      IF( IPAGE(IC,IL).EQ.IBLANK) GO TO 35
	  J=J+1
	  IF(J.GT.24) GO TO 60
	  DO (I=1,8)
	  	PIN(I,J)=IPAGE(IC,IL)
		IC=IC+1
		IF(IC.GT.80) GO TO 40
		IF(IPAGE(IC,IL).EQ.IBLANK) GO TO 40
	  REPEAT
  60  DO(J=1,12)
      	II=0
  65    II=II+1
        IF(II.EQ.9) GO TO 75
		IF(PIN(II,J).NE.IBLANK) GO TO 65
		I=9
  70    I=I-1
        II=II-1
		PIN(I,J)=PIN(II,J)
		PIN(II,J)=IBLANK
		IF(II.NE.1) GO TO 70
  75  REPEAT
	  WRITE(8,76) TITLE
  76  FORMAT(/,' ',80A1)
      WRITE(8,78) ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,
     .              ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,
     .              ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,
     .              ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR
  78  FORMAT(/,' ',14X,14A1,3X,14A1,
     .       /,' ',14X,A1,13X,A1,1X,A1,13X,A1)
	  JJ=24
	  DO(J=1,12)
      	WRITE(8,80) ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR
  80    FORMAT(' ',11X,4A1,29X,4A1)
        WRITE(8,81) (PIN(I,J),I=1,8), ISTAR,J,
     .       (IIN(I,1),I=1,8),JJ,ISTAR,(PIN(I,JJ),I=1,8)
  81    FORMAT(' ',8A1,3X,A1,I2,' ',11X,8A1,10X,' ',I2,A1,3X,8A1)
      	WRITE(8,82) ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR
  82    FORMAT(' ',11X,4A1,29X,4A1)
        WRITE(8,84) ISTAR,(IIN(I,2),I=1,8),ISTAR
  84    FORMAT(' ',14X,A1,11X,8A1,10X,A1)
        DO(II=1,2)
			DO(I=1,8)
				IIN(I,II)=IBLANK
			REPEAT
        REPEAT
		JJ=JJ-1
	  REPEAT
      WRITE(8,90) ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,
     .              ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,
     .              ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,
     .              ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR,ISTAR
  90  FORMAT(' ',14X,31A1)
      CLOSE(8)
      RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE PLOT(LBUF,IBUF,LFUSES,IPROD,TITLE,LDUMP,ITYPE,LPROD,
     .                 IOP,IBLOW,I88PRO,I8PRO,cmdline)
C
C this subroutine produces the fuse plot
C
	  IMPLICIT NONE
	  INTEGER IBUF(8,24),IOUT(64),ISAVE(80,40),TITLE(80),
     .     IPROD,ITYPE,IOP,IBLOW,I88PRO,I8PRO,PMS,POF,PDF,IAND,
     .     IOR,ISLASH,IDASH,X,IBLANK,P,B,D,ZERO,ONE,FX,FIDASH,
     .     I,J,LEN,K,IDATA(40)
	  LOGICAL LBUF(24),LFUSES(40,80),LDUMP,LPROD(80)
      CHARACTER cmdline*20,plotname*25,STX,ETX
      PARAMETER (STX=2,ETX=3)
	  COMMON /LUNIT/ PMS,POF,PDF
	  DATA ISAVE/3200*' '/,IAND/'*'/,IOR/'+'/,ISLASH/'/'/,
     .     IDASH/'-'/,X/'X'/,IBLANK/' '/,P/'P'/,B/'B'/,
     .     D/'D'/,ZERO/'0'/,ONE/'1'/,FX/'0'/,FIDASH/'0'/
C
      IF(LDUMP) GO TO 58
	  IF(ISAVE(IPROD,1).NE.IBLANK) RETURN
	  IF(LBUF(1)) GO TO 5
	  DO(J=1,39)
	  	ISAVE(IPROD,J)=ISAVE(IPROD,J+1)
	  REPEAT
	  ISAVE(IPROD,40)=ISLASH
  5   DO(I=1,8)
	  	IF(ISAVE(IPROD,1).NE.IBLANK) RETURN
		IF(IBUF(I,1).EQ.IBLANK) GO TO 20
		DO(J=1,39)
			ISAVE(IPROD,J)=ISAVE(IPROD,J+1)
		REPEAT
		ISAVE(IPROD,40)=IBUF(I,1)
  20  REPEAT
      IF(ISAVE(IPROD,1).NE.IBLANK) RETURN
	  DO(J=1,39)
	  	ISAVE(IPROD,J)=ISAVE(IPROD,J+1)
	  REPEAT
	  ISAVE(IPROD,40)=IAND
	  RETURN
C
C print fuse plot
C
  58  plotname = cmdline
	  len = index(cmdline,' ')
C
      IF(IOP.EQ.D) THEN
	  	plotname(len:) = '.jed'
		GO TO 60
      ELSE IF(IOP.EQ.B) THEN
	  	plotname(len:) = '.brf'
		GO TO 60
      ELSE 
	  	plotname(len:) = '.plt'
	  ENDIF
C
  60  PRINT*,'Writing file ',plotname
      OPEN(UNIT=1,FILE=plotname,STATUS='new')
C
      IF(IOP.EQ.D) GO TO 62
      WRITE(1,61) TITLE
  61  FORMAT(/,' ',80A1,//,
     . '                11 1111 1111 2222 2222 2233 3333 3333',/,
     . '    0123 4567 8901 2345 6789 0123 4567 8901 2345 6789',/)
	  GO TO 64
C
C STX determines the starting character for DATA I/O format
C
  62  WRITE(1,63) STX
  63  FORMAT(' ',A1,/,'*L0000'/)
  64  DO(I88PRO=1,73,8)
	  	DO(I8PRO=1,8)
			IPROD=I88PRO+I8PRO-1
			ISAVE(IPROD,40)=IBLANK
			DO(I=1,40)
				IF(ISAVE(IPROD,1).NE.IBLANK) GO TO 70
				DO(J=1,39)
					ISAVE(IPROD,J)=ISAVE(IPROD,J+1)
				REPEAT
				ISAVE(IPROD,40)=IBLANK
  70		REPEAT
            DO(I=1,24)
				IOUT(I+40)=ISAVE(IPROD,I)
			REPEAT
			IF(ISAVE(IPROD,25).NE.IBLANK) IOUT(64)=IDASH
			DO(I=1,40)
				IOUT(I)=X
				IF(LFUSES(I,IPROD)) IOUT(I)=IDASH
			REPEAT
            CALL FANTOM(ITYPE,IOP,IOUT,IPROD,I8PRO)
			IF(IOP.NE.D) GO TO 86
			K=0
  81        DO(I=1,40)
		IF((IOUT(I).EQ.FX).OR.(IOUT(I).EQ.FIDASH)) GO TO 82
				K=K+1
				IF(IOUT(I).EQ.X) IDATA(K)=ZERO
				IF(IOUT(I).EQ.IDASH) IDATA(K)=ONE
  82        REPEAT
            DO(I=1,40)
		IF((IOUT(I).EQ.X).OR.(IOUT(I).EQ.IDASH)) GO TO 84
			REPEAT
			GO TO 94
  84        WRITE(1,85) IDATA
  85        FORMAT(' ',40(A1))
            GO TO 94
  86        IPROD=IPROD-1
            IF((IOP.EQ.P).OR.((IOP.EQ.B).AND.(LPROD(IPROD+1))))
     .      WRITE(1,90) IPROD,IOUT
  90        FORMAT(' ',I2,10(' ',4A1),' ',24A1)
  94	REPEAT
        WRITE(1,96)
  96    FORMAT(1X)
  100 REPEAT
      IF(IOP.NE.D) GO TO 105
	  WRITE(1,101) ETX
  101 FORMAT('*',A1,'0000')
	  CLOSE(1)
      RETURN
  105 WRITE(1,110)
  110 FORMAT(/,
     .' LEGEND:  X : FUSE NOT BLOWN (L,N,0) - : FUSE BLOWN (H,P,1)')
	  IF(IOP.EQ.P) WRITE(1,111)
  111 FORMAT(
     .'          - : PHANTOM FUSE (L,N,0)   - : PHANTOM FUSE (H,P,1)')
	  WRITE(1,112) IBLOW
  112 FORMAT(/,' NUMBER OF FUSES BLOWN = ',I4)
      WRITE(1,113)
  113 FORMAT(//)
	  CLOSE(1)
      RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE HEX(LFUSES,IOP,cmdline)
C
C this subroutine generates hex programming formats
C
	  IMPLICIT NONE
	  INTEGER ITEMP(80),ITABLE(32),IOP,PMS,POF,PDF,H,S,LEN,
     .     I,INC,IPROD,J,IINPUT,IHEX
	  LOGICAL LFUSES(40,80)
      CHARACTER cmdline*20,hexname*25,STX,ETX,SOH
      PARAMETER (SOH=1,STX=2,ETX=3)
	  COMMON /LUNIT/PMS,POF,PDF
	  DATA H/'H'/,S/'S'/,
     .     ITABLE/'00','01','02','03','04','05','06','07',
     .            '08','09','0A','0B','0C','0D','0E','0F',
     .            '10','11','12','13','14','15','16','17',
     .            '18','19','1A','1B','1C','1D','1E','1F'/
C
      hexname = cmdline
	  len = index(cmdline,' ')
	  hexname(len:) = '.hex'
C
      PRINT*,'Writing file ',hexname
      OPEN(UNIT=1,FILE=hexname,STATUS='new')
C
C ***** note: some prom programmers need a start character.
C ***** this program outputs an stx for the DATA I/O model 9
C ***** (use SOH instead of STX for model 5)
C
      WRITE(1,5)STX
  5   FORMAT(A1)
	  IF(IOP.EQ.H) WRITE(1,10)
  10  FORMAT(//,80(' '),//)
C
      DO(I=1,41,40)
	  	INC=I-1
		DO (IPROD=1,7,2)
			DO(J=1,2)
				DO(IINPUT=1,40)
					IHEX=0
			IF(LFUSES(IINPUT,IPROD+J-1+0+INC)) IHEX=IHEX+1
			IF(LFUSES(IINPUT,IPROD+J-1+8+INC)) IHEX=IHEX+2
			IF(LFUSES(IINPUT,IPROD+J-1+16+INC)) IHEX=IHEX+4
			IF(LFUSES(IINPUT,IPROD+J-1+24+INC)) IHEX=IHEX+8
			IF(LFUSES(IINPUT,IPROD+J-1+32+INC)) IHEX=IHEX+16
		    ITEMP(IINPUT+40*(J-1))=ITABLE(IHEX+1)
				REPEAT
				ITEMP(IINPUT+40*(J-1))=ITABLE(IHEX+1)
			REPEAT
			IF(IOP.EQ.H) WRITE(1,60)ITEMP
 60         FORMAT(4(' ',20(A2,' '),'.',/))
            IF(IOP.EQ.S) WRITE(1,70)
		REPEAT
        IF(IOP.EQ.S) WRITE(1,70)
      REPEAT
 61   FORMAT(4(' ',20A2,'.',/))
      IF(IOP.EQ.H) WRITE(1,70)
 70   FORMAT(//,80(' '),//)
      WRITE(1,75)ETX
 75   FORMAT(A1)
	  CLOSE(1)
      RETURN
	  END
C
C ********************************************************
C
      BLOCK DATA
	  IMPLICIT NONE
	  INTEGER PR8X10(10,14),PROD8(8,11),PRODLN(40,7)
	  COMMON /BLK/ PR8X10(10,14),PROD8(8,11),PRODLN(40,7)
	  DATA PR8X10/
     .       4,4,4,4,4,4,4,4,4,4,
     .       3,6,5,5,5,5,5,5,6,3,
     .       3,3,7,7,8,8,7,7,3,3,
     .       3,3,3,9,10,10,9,3,3,3,
     .       3,3,3,3,1,1,3,3,3,3,
     .       3,3,3,3,1,1,3,3,3,3,
     .       11,11,11,11,11,11,11,11,11,11,
     .       11,11,11,11,11,11,11,11,11,11,
     .       11,11,11,11,11,11,11,11,11,11,
     .       11,11,11,11,11,11,11,11,11,11,
     .       3,1,1,1,1,1,1,1,1,3,
     .       3,1,1,1,1,1,1,1,1,3,
     .       3,1,1,1,1,1,1,1,1,3,
     .       3,1,1,1,1,1,1,1,1,3/
	  DATA PROD8/
     .       1,1,1,1,1,1,1,1,
     .       2,2,2,2,2,2,2,2,
     .       3,3,3,3,3,3,3,3,
     .       4,4,3,3,3,3,3,3,
     .       5,5,3,3,3,3,3,3,
     .       5,5,5,5,3,3,3,3,
     .       6,6,6,6,3,3,3,3,
     .       6,6,3,3,3,3,3,3,
     .       7,7,7,7,7,7,3,3,
     .       7,7,7,7,3,3,3,3,
     .       1,1,1,1,3,3,3,3/
	  DATA PRODLN/
     .       40*1HX,
     .       40*1HP,
     .       40*1HN,
     .       6*1HX,2*1HP,2*1HX,2*1HP,2*1HX,2*1HP,2*1HX,
     .       2*1HP,2*1HX,2*1HP,2*1HX,2*1HP,2*1HX,2*1HP,
     .       2*1HX,2*1HP,4*1HX,
     .       10*1HX,2*1HP,2*1HX,2*1HP,2*1HX,2*1HP,2*1HX,
     .       2*1HP,2*1HX,2*1HP,2*1HX,2*1HP,8*1HX,
     .       14*1HX,2*1HP,2*1HX,2*1HP,2*1HX,2*1HP,2*1HX,
     .       2*1HP,12*1HX,
     .       18*1HX,2*1HP,2*1HX,2*1HP,16*1HX/
	  END
C
C ********************************************************
C
      SUBROUTINE TWEEK(ITYPE,LFUSES)
C
C this subroutine tweeks the lfuses (the programming fuse plot)
C for high and low phantom fuses
C
      IMPLICIT NONE
	  INTEGER ITYPE,PR8X10(10,14),PROD8(8,11),PRODLN(40,7),
     .        P,N,FUSPTR,OUTPUT,GRTYPE,COL,LNTYPE,IROW
	  LOGICAL LFUSES(40,80),LBLANK,LLEFT,LAND,LOR,LSLASH,
     .        LEQUAL,LRIGHT,LXOR
	  COMMON LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
	  COMMON /BLK/ PR8X10(10,14),PROD8(8,11),PRODLN(40,7)
	  DATA P/'P'/,N/'N'/
	  FUSPTR=1
	  DO(OUTPUT=1,10)
	  	GRTYPE=PR8X10(OUTPUT,ITYPE)
		DO(IROW=1,8)
		LNTYPE=PROD8(IROW,GRTYPE)
		  DO(COL=1,40)
		  IF(PRODLN(COL,LNTYPE).EQ.P) LFUSES(COL,FUSPTR)=.TRUE.
		  IF(PRODLN(COL,LNTYPE).EQ.N) LFUSES(COL,FUSPTR)=.FALSE.
		  REPEAT
		FUSPTR=FUSPTR+1
		REPEAT
	  REPEAT
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE BINR(LFUSES,H,L)
C
C this subroutine generates binary programming formats
C
      IMPLICIT NONE
	  INTEGER ITEMP(5,10),H,L,PMS,POF,PDF,COL,INC,
     .        I,IPROD,J,K,IINPUT
	  LOGICAL LFUSES(40,80)
	  COMMON /LUNIT/ PMS,POF,PDF
	  WRITE(PDF,10)
   10 FORMAT(//,'                                      .',//)
	  DO(COL=1,40,40)
	  	INC=I-1
		DO(IPROD=1,8)
			DO(J=1,49,10)
				DO(K=1,10)
					IINPUT=J+K-1
					ITEMP(1,K)=L
					ITEMP(2,K)=L
					ITEMP(3,K)=L
					ITEMP(4,K)=L
					ITEMP(5,K)=L
			IF(LFUSES(IINPUT,IPROD+0+INC)) ITEMP(5,K)=H
			IF(LFUSES(IINPUT,IPROD+10+INC)) ITEMP(4,K)=H
			IF(LFUSES(IINPUT,IPROD+20+INC)) ITEMP(3,K)=H
			IF(LFUSES(IINPUT,IPROD+30+INC)) ITEMP(2,K)=H
			IF(LFUSES(IINPUT,IPROD+40+INC)) ITEMP(1,K)=H
				REPEAT
			WRITE(PDF,30) ITEMP
			REPEAT
		WRITE(PDF,30) ITEMP
		REPEAT
      WRITE(PDF,30) ITEMP
	  REPEAT
   30 FORMAT(' ',10('B',5A1,'F'))
	  WRITE(PDF,10)
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE SLIP(LFUSES,I88PRO,ITYPE,IBLOW)
C
C this subroutine will blow the entire conditional three state
C product line when 'IF(VCC)' condition is used for the
C corresponding output pin

      IMPLICIT NONE
      INTEGER IENABL(10,14),I88PRO,ITYPE,IBLOW,IOUT,I
      LOGICAL LFUSES(40,80)
C
C 1=enabled output  0=anything else for that output
C
	  DATA IENABL/
     .		0,0,0,0,0,0,0,0,0,0,
     .		0,0,0,0,0,0,0,0,0,0,
     .		0,0,0,0,0,0,0,0,0,0,
     .		0,0,0,0,0,0,0,0,0,0,
     .		0,0,0,0,0,0,0,0,0,0,
     .		0,0,0,0,0,0,0,0,0,0,
     .		1,1,1,1,1,1,1,1,1,1,
     .		0,0,0,0,0,0,0,0,0,0,
     .		1,0,0,0,0,0,0,0,0,1,
     .		1,1,1,0,0,0,0,1,1,1,
     .		0,1,1,1,1,1,1,1,1,0,
     .		0,0,0,0,0,0,0,0,0,0,
     .		0,1,0,0,0,0,0,0,1,0,
     .		0,1,1,0,0,0,0,1,1,0/

	  IOUT = (I88PRO-1)/8+1
	  IF(IENABL(IOUT,ITYPE).EQ.0) RETURN
	  DO(I=1,40)
	  	IBLOW = IBLOW+1
		LFUSES(I,I88PRO) = .TRUE.
	  REPEAT
	  I88PRO = I88PRO+1
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE FANTOM(ITYPE,IOP,IOUT,IPROD,I8PRO)
C
C this subroutine updates IOUT (the printed fuse plot)
C for high and low phantom fuses
C 

      IMPLICIT NONE
      INTEGER IOUT(64),ITYPE,IOP,IPROD,I8PRO,PR8X10(10,14),
     .        PROD8(8,11),PRODLN(40,7),IROW,
     .        HIFANT,IBLANK,LNTYPE,GRTYPE,COL,P,B
      LOGICAL LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
	  COMMON LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
	  COMMON /BLK/ PR8X10(10,14),PROD8(8,11),PRODLN(40,7)
	  DATA HIFANT/'0'/,IBLANK/' '/
C
      IROW=((IPROD-1)/8)+1
      GRTYPE=PR8X10(IROW,ITYPE)
	  LNTYPE=PROD8(I8PRO,GRTYPE)
C
	  DO(COL=1,40)
	 IF(PRODLN(COL,LNTYPE).EQ.P.AND.IOP.EQ.P) IOUT(COL)=HIFANT
	 IF(PRODLN(COL,LNTYPE).EQ.P.AND.IOP.EQ.B) IOUT(COL)=IBLANK
C	 IF(PRODLN(COL,LNTYPE).EQ.N) 
	  REPEAT
	  RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE IODC2
C
C this subroutine turns on peripherals (optional)
C 

      IMPLICIT NONE
      INTEGER PMS,POF,PDF,DC2,BEL
	  COMMON /LUNIT/ PMS,POF,PDF
	  DATA DC2/18/,BEL/7/
	  WRITE(PDF,10) DC2,BEL
   10 FORMAT(' ',2A1)
      RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE IODC4
C
C this subroutine turns off peripherals (optional)
C 

      IMPLICIT NONE
      INTEGER PMS,POF,PDF,DC3,DC4,BEL
	  COMMON /LUNIT/ PMS,POF,PDF
	  DATA DC3/19/,DC4/20/,BEL/7/
	  WRITE(PDF,10) BEL,DC3,DC4
   10 FORMAT(' ',3A1)
      RETURN
	  END
C
C ********************************************************
C
      SUBROUTINE TEST(LPHASE,LBUF,TITLE,IC,IL,ILE,ISYM,
     .                IBUF,ITYPE,cmdline)
C
C this subroutine performs the function table simulation
C and generates test vectors
C 

      IMPLICIT NONE
      INTEGER ISYM(8,24),ISYM1(8,24),IBUF(8,24),IVECT(24),
     .        IVECTP(24),ISTATE(24),ISTATT(24),IPIN(24),TITLE(80),
     .        IC,IL,ILE,ITYPE,IPAGE(80,200),PMS,POF,PDF,IFUNCT,
     .        IDESC,IEND,IDASH,L,H,X,C,Z,N0,N1,IBLANK,COMMENT,
     .        LEN,ITRST,I,J,IMATCH,ICLOCK,IMAX,NVECT,IC1,IL1,
     .        IINP,ILL,ITEST,IOUTP,XORSUM,ISUM,IPROD,IIFB,IMESS,
     .        ILERR
	  LOGICAL LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR,LSAME,
     .		  XORFND,LERR,LPHASE(24),LPHAS1(24),LBUF(24),LOUT(24),
     .		  LOUTP(24),LCLOCK,LPTRST,LCTRST,LENABL(24),NREG
      CHARACTER cmdline*20,simname*25
	  COMMON LBLANK,LLEFT,LAND,LOR,LSLASH,LEQUAL,LRIGHT,LXOR
      COMMON	/PGE/ IPAGE(80,200)
      COMMON    /LUNIT/ PMS,POF,PDF
      COMMON    /FTEST/ IFUNCT,IDESC,IEND
	  DATA IDASH/'-'/,L/'L'/,H/'H'/,X/'X'/,C/'C'/,Z/'Z'/,N0/'0'/,
     .     N1/'1'/,IBLANK/' '/,COMMENT/';'/
C
C open a file for the simulation vectors
C
      simname = cmdline
	  len = index(cmdline,' ')
	  simname(len:) = '.sim'
	  OPEN(UNIT=12,FILE=simname,STATUS='new')
C
C print an error message if no function table is supplied
C
	  IF(IFUNCT.NE.0) GO TO 3
	  WRITE(PMS,2)
    2 FORMAT(/,' FUNCTION TABLE MUST BE SUPPLIED IN ORDER TO PERFORM',
     .       ' SIMULATION')
	  RETURN
C
C print title
C
    3 PRINT*,'Writing file ',simname
      WRITE(12,4) TITLE
    4 FORMAT(/,' ',80A1,/)
C
C initialize LERR (error flag) to no error
C
	  LERR=.FALSE.
C
C set the starting point of the function table to column 0
C and IFUNCT + 1
C
	  IC=0
	  IL=IFUNCT + 1
C
C initialize ITRST (three state enable function table pin number)
C
	  ITRST=0
C
C make a dummy call to INCR
C
	  CALL INCR(IC,IL)
C
C set the function table pin list (up to 22)
C and go 1 more than max to look for dashed line
C
	  DO(I=1,23)
	  	CALL GETSYM(LPHAS1,ISYM1,I,IC,IL)
		DO(J=1,8)
			IBUF(J,1) = ISYM1(J,I)
		REPEAT
		IF(IBUF(8,1).EQ.IDASH) GO TO 12
		CALL MATCH(IMATCH,IBUF,ISYM)
		IF(IMATCH.NE.0) GO TO 7
		WRITE(PMS,6) (IBUF(J,1),J=1,8)
    6   FORMAT(/,' FUNCTION TABLE PIN LIST ERROR AT ',8A1)
	    RETURN
    7   LOUT(I) = .FALSE.
	    ISTATT(I) = X
	    IVECTP(I) = X
C
C if appropiate pal type, remember location of the clock and the 
C three state enable pin in the function table pin list
C
	    IF(.NOT.(ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.10.OR.
     .    ITYPE.EQ.12.OR.ITYPE.EQ.13.OR.ITYPE.EQ.14) ) GO TO 10
   	    IF(IMATCH.EQ.1) ICLOCK = I
		IF(IMATCH.EQ.13) ITRST = I
   10   IPIN(I)=IMATCH
	  REPEAT
C
C all signal names for the functional test have been read in
C adjust the count
C
   12 IMAX = I - 1
      NVECT = 0
C
C ************ start of main loop for simulation *************
C
   90 NVECT = NVECT + 1
      IC1 = 0
	  IL1 = ILE
c
C go passed the comment lines
C
   23 IF(IPAGE(1,IL).EQ.COMMENT) THEN
      	IL = IL + 1
	  	GO TO 23
	  ENDIF
C
C get vectors from the function table
C
	  DO(I=1,IMAX)
	  	IF(IPAGE(IC,IL).EQ.IBLANK) GO TO 21
		GO TO 22
   21 	IC = IC + 1
	  	IF(IPAGE(IC,IL).EQ.IBLANK) GO TO 21
   22 	IVECT(I) = IPAGE(IC,IL)
      	IC = IC + 1
	  REPEAT
C
C advance line count to skip function table comments
C
	  IL = IL + 1
	  IC = 1
	  IF(IVECT(1).EQ.IDASH) GO TO 95
C
C check for valid function table values (H,L,X,Z,C)
C
      DO(I=1,IMAX)
        IF((IVECT(I).EQ.H).OR.(IVECT(I).EQ.L).OR.(IVECT(I).EQ.X).OR.
     .   (IVECT(I).EQ.C).OR.(IVECT(I).EQ.Z)) GO TO 11 
        WRITE(PMS,8) IVECT(I),NVECT
    8   FORMAT(/,' ',A1,' IS NOT AN ALLOWED FUNCTION TABLE ',
     .         'ENTRY IN VECTOR ',I3)
        RETURN
   11 REPEAT
C
C initialize clock and three state enable flags
C
	  LCLOCK = .FALSE.
	  LCTRST = .TRUE.
	  LPTRST = .TRUE.
	  DO(I=1,IMAX)
	  	LENABL(I) = .TRUE.
	  REPEAT
C
C initialize NREG (not registered output) to false
C
	  NREG = .FALSE.
C
C initialize ISTATE array to all X's
C
	  DO(I=1,24)
	  	ISTATE(I)=X 
	  REPEAT
C
C check if this pal type has registers
C
  	  IF( .NOT.(ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.10.OR.
     .   ITYPE.EQ.12.OR.ITYPE.EQ.13.OR.ITYPE.EQ.14) ) GO TO 25
C
C check clock and three state enable pins and change flag if needed
C
	  IF(IVECT(ICLOCK).EQ.C) LCLOCK = .TRUE.
	  IF(ITRST.EQ.0) GO TO 25
	  LSAME = ((LPHASE(13)).AND.(LPHAS1(ITRST)).OR.
     .        (.NOT.LPHASE(13)).AND.(.NOT.LPHAS1(ITRST)))
	  IF(IVECT(ITRST).EQ.L.AND.(.NOT.LSAME).OR.
     .   IVECT(ITRST).EQ.H.AND.(LSAME)) LPTRST = .FALSE.
	  IF(LPTRST) GO TO 25
C
C disable registered outputs if appropiate
C
	  DO(I=1,IMAX)
	  	J = IPIN(I)
	IF(J.EQ.17.OR.J.EQ.18.OR.J.EQ.19.OR.J.EQ.20) LENABL(I)=.FALSE.
  	    IF((ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.12.OR.
     .     ITYPE.EQ.13).AND.(J.EQ.16.OR.J.EQ.21)) LENABL(I)=.FALSE.
  	    IF((ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.12).AND.
     .     (J.EQ.15.OR.J.EQ.22)) LENABL(I) = .FALSE.
  	    IF(ITYPE.EQ.8.AND.(J.EQ.14.OR.J.EQ.23)) LENABL(I) = .FALSE.
	  REPEAT
C
C **************** scan through the logic equations *********
C
C make a dummy call to INCR
C
   25 CALL INCR(IC1,IL1)
   26 CALL GETSYM(LBUF,IBUF,1,IC1,IL1)
      IF(LLEFT) GO TO 29
   27 IF(.NOT.LEQUAL) GO TO 26
C
C evaluate conditional three state product line
C
   29 IF(LEQUAL) GO TO 35
      NREG = .TRUE.
   33 CALL GETSYM(LBUF,IBUF,1,IC1,IL1)
      CALL MATCH(IINP,IBUF,ISYM1)
C
C check for GND,VCC,/GND,or /VCC in conditional three state
C product line
C
	  IF(IINP.NE.0) GO TO 32
	  CALL MATCH(IMATCH,IBUF,ISYM)
	  ILL = IL1
	  IF(IMATCH.EQ.12.AND.(LBUF(1)).OR.
     .   IMATCH.EQ.24.AND.(.NOT.LBUF(1))) LCTRST = .FALSE.
	  IF(IINP.EQ.0.AND.IMATCH.NE.12.AND.IMATCH.NE.24) GO TO 100
	  GO TO 34
   32 ITEST = IVECT(IINP)
      IF(ITEST.EQ.L.AND.(LPHAS1(IINP)).AND.(LBUF(1))
     .   .OR.ITEST.EQ.H.AND.(LPHAS1(IINP)).AND.(.NOT.LBUF(1))
     .   .OR.ITEST.EQ.H.AND.(.NOT.LPHAS1(IINP)).AND.(LBUF(1))
     .   .OR.ITEST.EQ.L.AND.(.NOT.LPHAS1(IINP)).AND.(.NOT.LBUF(1))
     .   ) LCTRST = .FALSE.
	  IF(ITEST.EQ.X.OR.ITEST.EQ.Z) LCTRST = .FALSE.
   34 IF(LAND) GO TO 33
      GO TO 27
C
C evaluate the logic equation
C find pin number of the output vectors
C
   35 CALL MATCH(IOUTP,IBUF,ISYM1)
      ILL = IL1
	  IF(IOUTP.EQ.0) GO TO 100
	  IF(NREG) LENABL(IOUTP) = LCTRST
	  LOUT(IOUTP) = .TRUE.
	  IF(.NOT.LCTRST) LOUT(IOUTP) = .FALSE.
	  LCTRST = .TRUE.
	  LOUTP(IOUTP) = LBUF(1)
C
C determine product term and eventually sum for output keeping
C track to see if an XOR (exclusive or) has been found
C
	  XORSUM = H
	  XORFND = .FALSE.
	  ISUM = L
   28 IPROD = H
   30 ILL = IL1
      CALL GETSYM(LBUF,IBUF,1,IC1,IL1)
	  CALL MATCH(IINP,IBUF,ISYM1)
	  IF(IINP.NE.0) GO TO 45
	  CALL MATCH(IMATCH,IBUF,ISYM)
	  IF(IMATCH.NE.12) GO TO 100
	  ITEST = L
	  IINP = 23
	  LPHAS1(23) = .TRUE.
	  GO TO 37
   45 ITEST = IVECT(IINP)
C
C get feed back values
C
	  IF((.NOT.LCLOCK).OR.(NREG)) GO TO 37
	  CALL MATCH(IIFB,IBUF,ISYM)
	  IF((ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.10.OR.ITYPE.EQ.12.OR.
     .    ITYPE.EQ.13.OR.ITYPE.EQ.14) .AND.(IIFB.EQ.17.OR.IIFB.EQ.18.OR.
     .    IIFB.EQ.19.OR.IIFB.EQ.20)) ITEST = IVECTP(IINP)
	  IF((ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.12.OR.ITYPE.EQ.13)
     .   .AND.(IIFB.EQ.16.OR.IIFB.EQ.21)) ITEST = IVECTP(IINP)
	  IF((ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.12).AND.
     .   (IIFB.EQ.15.OR.IIFB.EQ.22)) ITEST = IVECTP(IINP)
	  IF((ITYPE.EQ.8).AND.(IIFB.EQ.14.OR.IIFB.EQ.23)) 
     .    ITEST = IVECTP(IINP)
   37 IF(ITEST.EQ.X.OR.ITEST.EQ.Z) ITEST = L
      IF(ITEST.EQ.L.AND.(LPHAS1(IINP)).AND.(LBUF(1))
     .   .OR.ITEST.EQ.H.AND.(LPHAS1(IINP)).AND.(.NOT.LBUF(1))
     .   .OR.ITEST.EQ.H.AND.(.NOT.LPHAS1(IINP)).AND.(LBUF(1))
     .   .OR.ITEST.EQ.L.AND.(.NOT.LPHAS1(IINP)).AND.(.NOT.LBUF(1))
     .   ) IPROD = L
	  IF(LAND) GO TO 30
	  IF(ISUM.EQ.L.AND.IPROD.EQ.X) ISUM = X
	  IF((ISUM.NE.H).AND.IPROD.EQ.H) ISUM = H
C
C check for XOR (exclusive or) and save intermediate value
C
	  IF(.NOT.LXOR) GO TO 31
	  XORSUM = ISUM
	  XORFND = .TRUE.
	  ISUM = L
	  GO TO 28
   31 IF(LOR) GO TO 28
C
C if end of equation has been found, determine final sum and save it
C
	  IF(.NOT.XORFND) ISTATT(IOUTP) = ISUM
	  IF((XORFND).AND.((ISUM.EQ.L.AND.XORSUM.EQ.L).OR.
     .  (ISUM.EQ.L.AND.XORSUM.EQ.H))) ISTATT(IOUTP) = L
	  IF((XORFND).AND.((ISUM.EQ.H.AND.XORSUM.EQ.L).OR.
     .  (ISUM.EQ.L.AND.XORSUM.EQ.H))) ISTATT(IOUTP) = H
	  IF((XORFND).AND.((ISUM.EQ.X.AND.XORSUM.EQ.X)))ISTATT(IOUTP)=X 
	  NREG = .FALSE.
C
C check if all equations have been processed by comparing current
C line number with function table line number
C
	  IF(IDESC.NE.0.AND.IL1.LT.IFUNCT.AND.IL1.LT.IDESC.OR.
     .   IDESC.EQ.0.AND.IL1.LT.IFUNCT) GO TO 27
C
C determine output logic values
C compare outputs to see if vector agrees with results
C
	  DO(I=1,IMAX)
	  	IF(.NOT.LOUT(I)) GO TO 50
		IF(ISTATT(I).EQ.X.AND.IVECT(I).EQ.X) GO TO 50
		LSAME = ((LOUTP(I)).AND.(LPHAS1(I)).OR.
     .          (.NOT.LOUTP(I)).AND.(.NOT.LPHAS1(I)))
      IMESS = 40
      IF(ISTATT(I).EQ.L.AND.IVECT(I).EQ.L.AND.(.NOT.LSAME))IMESS=41
      IF(ISTATT(I).EQ.H.AND.IVECT(I).EQ.H.AND.(.NOT.LSAME))IMESS=42
      IF(ISTATT(I).EQ.L.AND.IVECT(I).EQ.H.AND.(LSAME)) IMESS = 42
      IF(ISTATT(I).EQ.H.AND.IVECT(I).EQ.L.AND.(LSAME)) IMESS = 41
      IF((LENABL(I)).AND.IVECT(I).EQ.Z) IMESS = 43
      IF((.NOT.LENABL(I)).AND.(LOUT(I)).AND.IVECT(I).NE.Z)IMESS=44
      IF(IMESS.NE.40) LERR = .TRUE.
      IF(IMESS.EQ.41) WRITE(PMS,41) NVECT,(ISYM1(J,I),J=1,8)
   41 FORMAT(/,' FUNCTION TABLE ERROR IN VECTOR',I3,' PIN =',8A1,
     .        ' EXPECT = H ACTUAL = L')
      IF(IMESS.EQ.42) WRITE(PMS,42) NVECT,(ISYM1(J,I),J=1,8)
   42 FORMAT(/,' FUNCTION TABLE ERROR IN VECTOR',I3,' PIN =',8A1,
     .        ' EXPECT = L ACTUAL = H')
      IF(IMESS.EQ.43) WRITE(PMS,43) NVECT,(ISYM1(J,I),J=1,8)
   43 FORMAT(/,' FUNCTION TABLE ERROR IN VECTOR',I3,' PIN =',8A1,
     .        ' EXPECT = OUTPUT ENABLE ACTUAL = Z')
      IF(IMESS.EQ.44) WRITE(PMS,44) NVECT,(ISYM1(J,I),J=1,8),IVECT(I)
   44 FORMAT(/,' FUNCTION TABLE ERROR IN VECTOR',I3,' PIN =',8A1,
     .        ' EXPECT = Z ACTUAL = ',A1)
   50 REPEAT
C
C change the order of vectors from the order of appearance in the
C function table to that of the pin list and tweek for output
C 
	  DO(I=1,24)
	  	DO(J=1,IMAX)
			IF(IPIN(J).NE.I) GO TO 55
			IF(IVECT(J).EQ.L.OR.IVECT(J).EQ.H) GO TO 51
			ISTATE(I) = IVECT(J)
			GO TO 65
   51       LSAME = ((LPHASE(I)).AND.(LPHAS1(J)).OR.
     .        (.NOT.LPHASE(I)).AND.(.NOT.LPHAS1(J)))
      IF(ITYPE.EQ.6.AND.(I.EQ.18.OR.I.EQ.19))LOUT(J)=.TRUE.
			IF((.NOT.LOUT(J)).AND.(LSAME).AND.
     .      IVECT(J).EQ.L) ISTATE(I) = N0 
			IF((.NOT.LOUT(J)).AND.(LSAME).AND.
     .      IVECT(J).EQ.H) ISTATE(I) = N1
			IF((.NOT.LOUT(J)).AND.(.NOT.LSAME).AND.
     .      IVECT(J).EQ.L) ISTATE(I) = N1
			IF((.NOT.LOUT(J)).AND.(.NOT.LSAME).AND.
     .      IVECT(J).EQ.H) ISTATE(I) = N0
			IF((LOUT(J)).AND.(LSAME).AND.
     .      IVECT(J).EQ.L.AND.(LENABL(J))) ISTATE(I) = L
			IF((LOUT(J)).AND.(LSAME).AND.
     .      IVECT(J).EQ.H.AND.(LENABL(J))) ISTATE(I) = H
			IF((LOUT(J)).AND.(.NOT.LSAME).AND.
     .      IVECT(J).EQ.L.AND.(LENABL(J))) ISTATE(I) = H
			IF((LOUT(J)).AND.(.NOT.LSAME).AND.
     .      IVECT(J).EQ.H.AND.(LENABL(J))) ISTATE(I) = L
	 		GO TO 65
   55 	REPEAT
C
C save present vectors for feed back used with next set of vectors
C if clock pulse and not Z ( Z would be an unrealistic value)
C
   65 IF((LCLOCK).AND.IVECT(J).NE.Z) IVECTP(J) = IVECT(J)
      REPEAT
C
C assign X to ground and 1 to VCC pin
C
	  ISTATE(12) = X
	  ISTATE(24) = N1
C
C print test vectors
C
	  WRITE(12,60) NVECT,(ISTATE(I),I=1,24)
   60 FORMAT(' ',I2,' ',24A1)
      GO TO 90
C
C terminate the simulation
C
   95 IF(.NOT.LERR) WRITE(12,67)
   67 FORMAT(/,' PASS SIMULATION')
      IF(.NOT.LERR) WRITE(PMS,68)
   68 FORMAT(/,' PASS SIMULATION')
      CLOSE(12)
      RETURN
C
C print an error message for an undefined pin name
C
  100 ILERR = ILL+4
      WRITE(PMS,101) (IBUF(I,1),I=1,8),ILERR,(IPAGE(I,ILL),I=1,80)
  101 FORMAT(/,' ERROR SYMBOL = ',8A1,'       IN LINE NUMBER ',I3,
     .      /,' ',80A1,/,' THIS PIN NAME IS NOT DEFINED IN THE ',
     .      ' FUNCTION TABLE PIN LIST')
	  RETURN
	  END