SUBROUTINE HCGSAV
C
C	This subroutine does the initialization of the .HCG files and
C	the writting of the .MAC files.
C
C+
	COMMON /PLTR/ ILun,IDev,IsTerm,IMode,IXMax,IYmax,
	1  Cnvrsn,CMag,CnvMag,IX0,IY0,KSetNo,IFancy,IBfDv3,
	1  CSize,DeltaH,DeltaV,Upsiln,CosUP,SinUP
	COMMON /HCDB/ ICASE, NVEC, IWIDTH, LL0, LL0D, SCALE, SCALED,
	1  COSUPC, SINUPC, COSUPD, SINUPD, COSUPT, SINUPT, DES, DEF
	COMMON /ETC/ NEWDO, OLDDO, DFAULT, MAPIN(128), SCALEF,
	1  NVCTRS(90), NCHAR, IVCTRS(800), ITIS, H, HD, TABFAC,
	2  ISETAV, TRNFRM, TABON, YWRITE, CHMIN, CHMAX, XMENU, YMENU,
	3  XC, YC, XCH, YCH, IPEN, COSTH, SINTH, XTAB0, YTAB0, 
	4  IXTAB, IYTAB, ICHAR, ISET(2)
	DIMENSION ISCALE(2)
	INTEGER OLDDO
	LOGICAL DFAULT, TRNFRM, TABON
	LOGICAL*1 ICHAR, ISET
	EQUIVALENCE ( SCALE, ISCALE )
C-
	LOGICAL*1 OUTDES(66), OUTDEF(52), MAPOUT(128)
	EQUIVALENCE ( OUTDES, OUTDEF )
	DIMENSION IWID(90), IADD(90), IVEC(8000), IVEC0(2),
	1  IDSCRB(256)
	EQUIVALENCE ( IVEC0(2), IVEC )
	LOGICAL*1 NAME(15), IANS
C - GENERATE THE OUT MAPPING.
	ENCODE(128,10,MAPOUT)
10	FORMAT('::AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSs'
	1  'TtUuVvWwXxYyZz00112233445566778899++--**//(())$$',
	1  '==  ,,..##[[]]%%""__!!&&''''??<<>>@@\\^^;;' )
C
C - READ IN OR WRITE OUT?
	IF( NEWDO .EQ. 5 ) GO TO 4100
C
C - READ IN FILE IDENTIFING CHARACTER.
	CALL ERASE
	CALL HOME
100	WRITE(2,110) 
110	FORMAT(/,'$HCST')
	READ(2,120,END=9200) JSET
120	FORMAT(I2)
	ENCODE(2,130,ISET) JSET
130	FORMAT(I2)
	IF( ISET(1) .EQ. ' ' ) ISET(1) = '0'
C
C - VALID FILE?
	IF( ( JSET .GE. 3 ) .AND. ( JSET .LE. 39 ) ) GO TO 200
	WRITE(2,140)
140	FORMAT(/,' Must be of form HCSTnn, where nn is 3-39.')
	GO TO 100
C
C - DOES A .HCG FILE EXIST?
200	ENCODE(15,210,NAME) ISET
210	FORMAT('[4,7]HCST',2A1,'.HCG')
	CALL CLOSE(1)
	CALL ASSIGN(1,NAME,15)
	DEFINE FILE 1 ( 91, 410, U, ISETAV )
	READ(1'91,ERR=300) LL0D, SCALED, HD, NVCTRS
	RETURN
C
C - ERROR IN .HCG FILE, TRY .MAC FILE.
300	WRITE(2,310) ISET, ISET
310	FORMAT(/,' Error in HCST',2A1,'.HCG, will try HCST',2A1,'.MAC.')
	ENCODE(15,320,NAME) ISET
320	FORMAT('[4,7]HCST',2A1,'.MAC')
	CALL CLOSE(1)
	CALL ASSIGN(1,NAME,15)
C
C - READ IN .MAC FILE.
	READ(1,330,END=3100,ERR=400) FLL0D, SCALED
330	FORMAT(9(/),6X,F5.0,5(/),12X,F8.6)
	LL0D = FLL0D - 64.
	GO TO 500
400	WRITE(2,410) ISET
410	FORMAT(/,' Attempting to read HCST',2A1,'.MAC in old format.')
	REWIND 1
	LL0D = 0
	READ(1,420,ERR=3100) SCALED
420	FORMAT(21(/),12X,F8.6)
C
C - READ IN DESCRIPTOR BLOCK.
500	READ(1,510) JUNK
	READ(1,510) JUNK
510	FORMAT(A2)
	DO 1000 I=1,128
	J = MAPIN(I)
1000	READ(1,1010) NVCTRS(J), IWID(J), IADD(J)
1010	FORMAT((8X,O4,1X,O4,/,8X,O7))
C - FIND LENGTH.
	IMAX = -1
	NMAX = 0
	DO 2000 I=1,90
	NMAX = NMAX + NVCTRS(I)
	IF( IADD(I) .LT. IMAX ) GO TO 2000
	IMAX = IADD(I)
	NCHAR = I
2000	CONTINUE
	IMAX = IMAX + NVCTRS( NCHAR )
C - READ IN DEFINITION BLOCK.
	READ(1,510) JUNK
	READ(1,2010,END=3100,ERR=3100) ( IVEC(J), J=0,IMAX )
2010	FORMAT((8X,O7,3(1X,O7)))
C
C - REWRITE AS .HCG FILE.
2100	ENCODE(15,210,NAME) ISET
	CALL CLOSE(1)
	CALL ASSIGN(1,NAME,15)
	DEFINE FILE 1 ( 91, 410, U, ISETAV )
C
	DO 3000 I=1,90
	NVEC = NVCTRS(I)
	ISTART = IADD(I)
	IEND = ISTART + NVEC
	DFAULT = .TRUE.
	LL0 = LL0D
	SCALE = SCALED
	IF( NVEC .EQ. 0 ) GO TO 2200
	IF( IVEC(ISTART) .GE. "40000 ) GO TO 2200
	DFAULT = .FALSE.
	LL0 = IVEC( ISTART ) - 64
	ISCALE(1) = IVEC( ISTART+1 )
	ISCALE(2) = IVEC( ISTART+2 )
	ISTART = ISTART + 3
	NVEC = NVEC - 3
2200	IF( NVEC .EQ. 0 ) WRITE(1'I) IWID(I), DFAULT, LL0, SCALE, H
	IF( NVEC .NE. 0 ) WRITE(1'I) IWID(I), DFAULT, LL0, SCALE, H,
	1  ( IVEC(J), J=ISTART,IEND )
3000	NVCTRS(I) = NVEC
	WRITE(1'91) LL0D, SCALED, HD, NVCTRS
	RETURN
C
C - NEITHER FILE EXISTS.
3100	WRITE(2,3110) ISET, ISET
3110	FORMAT(/,' Neither HCST',2A1,'.MAC nor HCST',2A1,'.HCG exist.',/,
	1  '$Do you wish to initialize this set? [Y/n] ')
	READ(2,3120,END=9200) IANS
3120	FORMAT(A1)
	CALL ITWAS( IANS, 'N', 1, ISOK )
	IF( ISOK .EQ. 1 ) GO TO 100
C
C - INITIALIZE .HCG FILE.
	NEWDO = -1
	DFAULT = .TRUE.
	CALL HCGSCL
	ENCODE(15,210,NAME) ISET
	CALL CLOSE(1)
	CALL ASSIGN(1,NAME,15)
	DEFINE FILE 1 ( 91, 410, U, ISETAV )
	DO 4000 I=1,90
	NVCTRS(I) = 0
4000	WRITE(1'I) 0, .TRUE., LL0D, SCALED, HD
	WRITE(1'91) LL0D, SCALED, HD, NVCTRS
	RETURN
C
C - WRITE OUT FILE.
4100	CALL ERASE
	CALL HOME
	WRITE(2,4110) ISET
4110	FORMAT(/,' Write out HCST',2A1,//,
	1  T18,'No',/,
	1  T18,'.COM',/,
	1  T18,'.DAT',/,
	1  T18,'.MAC',//,
	1  '$[N/c/d/m/]? ')
	READ(2,4120,END=9200) IANS
4120	FORMAT(A1)
	CALL ITWAS( IANS, 'CDM', 3, ISOK )
	IF( ISOK .LT. 4 ) GO TO 4200
C
C - CLOSE OUT FILE.
	CALL CLOSE(1)
	GO TO 9100
C
C - WRITE OUT .MAC FILE.
4200	ISAT = 0
	NMAX = 0
	DO 5000 I=1,90
	IADD(I) = ISAT
	NVEC = NVCTRS(I)
	NMAX = NMAX + NVEC
	IF( NVEC .EQ. 0 ) READ(1'I) IWID(I), DFAULT, LL0, SCALE, H
	IF( NVEC .NE. 0 ) READ(1'I) IWID(I), DFAULT, LL0, SCALE, H,
	1  ( IVCTRS(J), J=1,NVEC )
	IF( DFAULT ) GO TO 4300
	IVEC( ISAT ) = LL0 + 64
	IVEC( ISAT+1 ) = ISCALE(1)
	IVEC( ISAT+2 ) = ISCALE(2)
	IF( ISOK .EQ. 1 ) CALL FLTACD( IVEC( ISAT+1) )
	ISAT = ISAT + 3
	NVCTRS(I) = NVCTRS(I) + 3
C
4300	IF( NVEC .EQ. 0 ) GO TO 5000
	DO 5000 J=1,NVEC
	IVEC( ISAT ) = IVCTRS( J )
	ISAT = ISAT + 1
5000	CONTINUE
	CALL CLOSE(1)
C
	GO TO ( 7100, 6100, 5100 ), ISOK
C
5100	ENCODE(15,320,NAME) ISET
	CALL ASSIGN(1,NAME,15)
	WRITE(1,5110) ISET, ISET, ISET
5110	FORMAT('	.TITLE	HCST',2A1,/,
	1  '	.ENABL	LC',/,
	2  ';',/,
	3  ';	CALL HCST',2A1,' -- This subroutine describes and defines',
	4  ' Hershey',/,
	5  ';	character set ',2A1,'.',/,
	6  ';')
	WRITE(1,5120) ISET, ISET, FLOAT( LL0D+64 ), SCALED
5120	FORMAT('	.PSECT	HCST',2A1,/,
	1  'HCST',2A1,'::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 6000 I=1,128
	J = MAPIN(I)
6000	WRITE(1,6010) NVCTRS(J), IWID(J), MAPOUT(I), IADD(J)
6010	FORMAT(' 	.BYTE	',O4,',',O4,'	;',A1,/,
	1  ' 	.WORD	',O7)
C
	WRITE(1,6020)
6020	FORMAT('DFN:	;DEFINITION TABLE.')
C
	WRITE(1,6030) ( ( IVEC(I+J), I=0,3 ), J=0,ISAT,4 )
6030	FORMAT((' 	.WORD	',O7,3(',',O7)))
C
	CALL CLOSE(1)
	GO TO 9100
C
C - WRITE THE .DAT FILE.
6100	DO 7000 I=1,128
	J = MAPIN(I)
	IDSCRB(2*I-1) = IWID(J)*256 + NVCTRS(J)
7000	IDSCRB(2*I) = IADD(J)
	ENCODE(15,7010,NAME) ISET
7010	FORMAT('[4,7]HCST',2A1,'.DAT')
	CALL ASSIGN(1,NAME,15)
	WRITE(1) LL0D+64, SCALED, ISAT, IDSCRB
	WRITE(1) ( IVEC(I), I=0,ISAT )
	CALL CLOSE(1)
	GO TO 9100
C
C - WRITE OUT .COM FILE.
7100	ENCODE(15,7110,NAME) ISET
7110	FORMAT('[4,7]HCST',2A1,'.COM')
	CALL ASSIGN(1,NAME,15)
	WRITE(1,7120) ( ISET, I=1,7 )
7120	FORMAT('*DECK HCST',2A1,/,
	1  T11,'IDENT',T18,'HCST',2A1,/,
	1  '*',/,
	1  '*  CALL HCST',2A1,' -- This subroutine describes and defines',
	1  ' Hershey',/,
	1  '*  character set ',2A1,'.',/,
	1  '*',/,
	1  T11,'ENTRY',T18,'HCST',2A1,/,
	1  'TRACE',T11,'VFD',T18,'42/0HHCST',2A1,',18/HCST',2A1,/,
	1  '*')
	WRITE(1,7130) ISET
7130	FORMAT('HCST',2A1,T11,'DATA',T18,'0')
D	WRITE(1,7140)
D7140	FORMAT(T11,'SA3',T18,'LL',/,
D	1  T11,'BX6',T18,'X3',/,T11,'SA6',T18,'LL0D',/,
D	1  T11,'SA3',T18,'SCL',/,
D	1  T11,'BX6',T18,'X3',/,T11,'SA6',T18,'SCALED',/,
D	1  T11,'SX6',T18,'DSCRB',/,T11,'SA6',T18,'DES',/,
D	1  T11,'SX6',T18,'DFN',/,T11,'SA6',T18,'DEF')
	WRITE(1,7150) ISET, LL0D+64, SCALED
7150	FORMAT(T11,'EQ',T18,'HCST',2A1,/,
	1  '*',/,
	1  'LL',T11,'DATA',T18,I3,/,
	1  'SCL',T11,'DATA',T18,'D',F8.6,/
	1  '*')
DC
DC - WRITE OUT /HCDB/.
D	WRITE(1,7160)
D7160	FORMAT(T11,'USE',T18,'/HCDB/',/,
D	1  'ICASE',T11,'BSSZ',T18,'1',/,'NVEC',T11,'BSSZ',T18,'1',/,
D	1  'IWIDTH',T11,'BSSZ',T18,'1',/,'LL0',T11,'BSSZ',T18,'1',/,
D	1  'LL0D',T11,'BSSZ',T18,'1',/,'SCALE',T11,'BSSZ',T18,'1',/,
D	1  'SCALED',T11,'BSSZ',T18,'1')
D	WRITE(1,7170)
D7170	FORMAT('COSUPC',T11,'BSSZ',T18,'1',/,
D	1  'SINUPC',T11,'BSSZ',T18,'1',/,
D	1  'COSUPD',T11,'BSSZ',T18,'1',/,'SINUPD',T11,'BSSZ',T18,'1',/,
D	1  'COSUPT',T11,'BSSZ',T18,'1',/,'SINUPT',T11,'BSSZ',T18,'1',/,
D	1  'DES',T11,'BSSZ',T18,'1',/,'DEF',T11,'BSSZ',T18,'1',/,
D	1  'POINT',T11,'BSSZ',T18,'1',/,'IADD',T11,'BSSZ',T18,'1',/,
D	1  T11,'USE',T18,'*',/,'*')
C
C - WRITE OUT DESCRIPTOR TABLE.
	DO 8000 I=1,128,2
	J1 = MAPIN( I )
	J2 = MAPIN( I+1 )
	CALL COMDES( I, NVCTRS(J1), IWID(J1), IADD(J1),
	1  NVCTRS(J2), IWID(J2), IADD(J2), OUTDES )
8000	WRITE(1,8010) OUTDES
8010	FORMAT(66A1)
C
C - WRITE OUT DEFINITION TABLE.
	DO 9000 I=0,ISAT,4
	CALL COMDEF( I, IVEC(I), OUTDEF )
9000	WRITE(1,9010) OUTDEF
9010	FORMAT(52A1)
	WRITE(1,9020)
9020	FORMAT(T11,'END')
	CALL CLOSE(1)
C
C - TRY SOME MORE?
9100	WRITE(2,9110)
9110	FORMAT(/,'$Do you wish to continue? [y/N] ')
	READ(2,4120,END=9200) IANS
	CALL ITWAS( IANS, 'Y', 1, ISOK )
	IF( ISOK .EQ. 1 ) GO TO 100
C
9200	CALL PLTNOS
	STOP 'Program HCG'
	END