PROGRAM HCGMAK
C
C	This programs read in a data file from which a definition
C	of a character set is written.  It then read the proper
C	values into arrays and then writes the finished character
C	set out in .MAC format.
C
	DIMENSION IVEC(0:8000), NVCTRS(90), IWID(90), IADD(90)
	DIMENSION IDIR(4000), IDAT(16)
	LOGICAL*1 FILE(40), IS, IE, MAPOUT(128)
	COMMON /MAPPER/ IDC(65), MAPIN(128)
	COMMON /PLTR/ ILun, IDev, IsTerm, IMode, IXMax, IYMax,
	1  Cnvrsn, CMag, CnvMag, IX0, IY0, KSetNo, IFancy, IBfDv3,
	1  CSize, DeltaH, DeltaV, Upsiln, CosUp, SinUp, WidAdj
C
C - DEFINE THE OUT MAPPING.
	ENCODE(128,10,MAPOUT)
10	FORMAT('::AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSs'
	1  'TtUuVvWwXxYyZz00112233445566778899++--**//(())$$',
	1  '==  ,,..##[[]]%%""__!!&&''''??<<>>@@\\^^;;' )
	CALL PSEUDO
C
C - GET DEFINITION FILE NAME.
100	CALL ERASE
	CALL HOME
	WRITE(5,110)
110	FORMAT('$Definition filename: ')
	READ(5,120,END=4100) IFILE, FILE
120	FORMAT(Q,40A1)
	FILE( IFILE+1 ) = "0
C
C - OPEN DEFINITION FILE.
	CALL CLOSE(1)
	OPEN( UNIT=1, NAME=FILE, TYPE='OLD', READONLY, ERR=100 )
	READ(1,130) ISET
130	FORMAT(A2)
	READ(1,120) IFILE, FILE
	FILE( IFILE+1 ) = "0
	READ(1,140) LL0D, SCALED
	SF = SCALED/2.
140	FORMAT(I8,F10.0)
C
C - OPEN FILE AND READ IN INDEX TO CHARACTERS.
	CALL CLOSE(2)
	OPEN( UNIT=2, NAME=FILE, TYPE='OLD', READONLY,
	1  ACCESS='DIRECT', RECORDSIZE=8, ASSOCIATEVARIABLE=IREC,
	1  ERR=100 )
	DO 1000 I=1,250
1000	READ(2'I) ( IDIR( J+(I-1)*16 ), J=1,16 )
	INDEX = 1
	IYOFF = 0
	ISAT = 0
C
C - GENERATE TABLE ON SCREEN.
	DX = IXMAX/( 11.*CNVMAG )
	DY = IYMAX/( 10.*CNVMAG )
	DO 1001 I=1,128
	J = ICDC( MAPOUT(I) )
	XP = ( MOD(J-1,10) + .5 )*DX
	YP = ( 9 - ((J-1)/10) )*DY
1001	CALL HCGEN(XP-DELTAH,YP-DELTAV,MAPOUT(I),1)
	DO 1002 I=1,90
	NVCTRS(I) = 0
	IWID(I) = 0
1002	IADD(I) = 0
C
C - READ IN CHARACTER DEFINITIONS UNTIL END.
1100	READ(1,1110,END=3100) IS, IE, NOCHAR, ICHNG, NEWOFF, NOCNTR
1110	FORMAT(2A1,4I8)
	IF( ICHNG .NE. 0 ) IYOFF = NEWOFF
	ISTART = IS
	IEND = IE
	DO 3000 K=ISTART,IEND
	I = ICDC( K )
C
C - FIND REFERENCE TO CHARACTER.
	IF( NOCHAR - IDIR(INDEX) ) 1200, 1500, 1300
1200	INDEX = INDEX - 2
	IF( INDEX .LT. 0 ) GO TO 1400
	IF( NOCHAR - IDIR(INDEX) ) 1200, 1500, 1400
1300	INDEX = INDEX + 2
	JDIR = IDIR(INDEX)
	IF( JDIR .EQ. 0 ) GO TO 1400
	IF( NOCHAR - JDIR ) 1400, 1500, 1300
C
C - CHARACTER DOES NOT EXIST.
1400	STOP 'Character does not exist.'
C
C - GET ADDRESS OF CHARACTER DEFINITION.
1500	IREC = IDIR( INDEX+1 )
	READ(2'IREC) IDAT
	NVEC = IDAT(1) - 1
	NVCTRS(I) = NVEC
	CALL UNPACK( IDAT(2), ILEFT, IRIGHT, IPEN )
	IRIGHT = -IRIGHT
	IXOFF = ILEFT
	IWID(I) = IRIGHT - ILEFT
	IF( NOCNTR .NE. 1 ) GO TO 1501
	IXOFF = 0
	IWID(I) = IRIGHT
1501	IADD(I) = ISAT
C	WRITE(3,1510) K,I,NVCTRS(I),IWID(I),IADD(I)
1510	FORMAT(1X,A1,4I8)
	IF( NVEC .LE. 0 ) GO TO 3000
C
C - COPY VECTORS AFTER APPLYING OFFSETS.
	IPOS = 3
	XP = ( MOD(I-1,10) + .5 )*DX
	YP = ( 9 - ((I-1)/10) )*DY
	DO 2000 J=1,NVEC
	IF( IPOS .LE. 16 ) GO TO 1600
	READ(2'IREC) IDAT
	IPOS = 1
1600	CALL UNPACK( IDAT( IPOS ), IX, IY, IPEN )
	IPOS = IPOS + 1
	IX = IX - IXOFF
	IY = IY - IYOFF
	CALL PACK( IVEC(ISAT), IX, IY, IPEN )
	CALL CALPLT( XP+IX*SF, YP+IY*SF, IPEN )
2000	ISAT = ISAT + 1
C
C - GO TO NEXT CHARACTER.
3000	NOCHAR = NOCHAR + 1
C
C - GO TO READ IN ANOTHER SET OF DEFINITIONS.
	GO TO 1100
C
C - WRITE OUT .MAC FILE.
3100	ENCODE(10,3110,FILE) ISET
3110	FORMAT('HCST',A2,'.MAC')
	FILE(11) = "0
	CALL HOME
	WRITE(5,3120) ISAT+1
3120	FORMAT(40X,' Total Number of vectors:',I8)
	CALL ABSPLT(0,IFIX( 2.*DELTAV*CNVMAG), 3 )
	WRITE(5,3130) ( FILE(I), I=1,10 )
3130	FORMAT(/,'$Write out ',10A1,'? ')
	READ(5,3140) FILE(40)
3140	FORMAT(A1)
	CALL ITWAS( FILE(40), 'N', 1, ITIS )
	IF( ITIS .EQ. 1 ) GO TO 100
	CALL CLOSE(3)
	OPEN( UNIT=3, NAME=FILE, TYPE='NEW' )
	WRITE(3,3210) ISET, ISET, ISET
3210	FORMAT('	.TITLE	HCST',A2,/,
	1  '	.ENABL	LC',/,
	2  ';',/,
	3  ';	CALL HCST',A2,' -- This subroutine describes and defines',
	4  ' Hershey',/,
	5  ';	character set ',A2,'.',/,
	6  ';')
	WRITE(3,3220) ISET, ISET, FLOAT( LL0D ), SCALED
3220	FORMAT('	.PSECT	HCST',A2,/,
	1  'HCST',A2,'::MOV	#DSCRB,DES',/,
	2  '	MOV	#DFN,DEF',/,
	3  '	MOV	#',F5.0,',LL0D',/,
	4  '	MOV	SCL,SCALED',/,
	5  '	MOV	SCL+2,SCALED+2',/,
	6  '	RTS	PC',/,
	7  '					;',/,
	8  'SCL:	.FLT2	',F8.6,/,
	9  '					;',/,
	1  'DSCRB:	;DESCRIPTOR TABLE.')
C
	DO 4000 I=1,128
	J = MAPIN(I)
4000	WRITE(3,4010) NVCTRS(J), IWID(J), MAPOUT(I), IADD(J)
4010	FORMAT(' 	.BYTE	',O4,',',O4,'	;',A1,/,
	1  ' 	.WORD	',O7)
C
	WRITE(3,4020)
4020	FORMAT('DFN:	;DEFINITION TABLE.')
C
	WRITE(3,4030) ( ( IVEC(I+J), I=0,3 ), J=0,ISAT,4 )
4030	FORMAT((' 	.WORD	',O7,3(',',O7)))
	CALL CLOSE(3)
	GO TO 100
C
C - ALL DONE.
4100	STOP
	END