PROGRAM FMB
	BYTE TCHC(2),FLAG,DEV(6),YN
	BYTE VOLNAM(12),VUIC(2),PINF(2),DATMCR(14),INDXFN(24)
	BYTE IOSB(4),INBUFB(512),FN(9),FT(4),PRO(4),PROT(16)
	BYTE BMFN(24),FN1(30)
	INTEGER BITMAP(256),TCH,IPRM(6),FVER,IBMLI(2),MAXFI(2)
	INTEGER IOS(2),BMBNI(2),FDB(128)
	INTEGER*4 IBML,MAXF,BMBN
	DIMENSION INBUF(256),INBUF1(256)
	LOGICAL*2 CRT,INFO,IRE,BMFO,EXT
	EQUIVALENCE (IOS,IOSB),(INBUF,INBUFB),(BMBNI,BMBN)
	EQUIVALENCE (TCHC,TCH),(IBML,IBMLI),(MAXFI,MAXF)
	EQUIVALENCE (INBUF,IBMS),(INBUF(4),MAXFIL),
	1(INBUF(5),ICLFAC),(INBUF(8),VOLNAM),(INBUF(16),VUIC),
	2(INBUF(23),PINF),(INBUF(31),DATMCR)
	COMMON INBUF,IBML,DEV,BITMAP,IOS,CRT,INFO,IRE,BMBN,BMFO,
	1BMFN,PRO,PROT,FN,YN,FT,IPRM,IFN,IFSN,INDXFN,IND
	COMMON /ASTDAT/FLAG
	DATA INDXFN/5*' ','[','0',',','0',']','I','N','D','E','X','F',
	1'.','S','Y','S',';','1',0,0/
	DATA BMFN  /5*' ','[','0',',','0',']','B','I','T','M','A','P',
	1'.','S','Y','S',';','1',0,0/
	DATA TCHC/"12,0/
	DATA PRO/'R','W','E','D'/
	CALL ATTAST(5,5)
	CALL ERRSET(63,.TRUE.,.FALSE.,.FALSE.,.FALSE.,)
	CALL ERRSET(64,.TRUE.,.FALSE.,.FALSE.,.FALSE.,)
	CALL ERRSET(70,.TRUE.,.FALSE.,.FALSE.,.FALSE.,)
	BMFO=.FALSE.
	CRT =.FALSE.
	INFO=.FALSE.
	IRE =.FALSE.
	CALL GETADR(IPRM,TCH)
	IPRM(2)=2
	CALL WTQIO("2560,5,5,,,IPRM)
	IF(TCHC(2).NE.0) CRT=.TRUE.
10	IF(INFO) CLOSE(UNIT=1)
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	WRITE(5,100)
100	FORMAT(25X,'FILE MAP AND RECOVERY PROGRAM',//,
	1' THE FOLLOWING OPTIONS ARE AVALABLE : ',//
	2' ID = FIND FILE BY FILE ID',/,
	3' NM = "    "    "  "    NAME',/,
	4' LI = LIST INDEX FILE INFORMATION',/,
	9' EX = EXIT THE PROGRAM',//)
110	WRITE(5,120)
120	FORMAT('$ENTER DESIRED OPTION : ')
	READ(5,130) IOP
130	FORMAT(A2)
	I=0
	IF(IOP.EQ.'ID') I=1
	IF(IOP.EQ.'NM') I=2
	IF(IOP.EQ.'LI') I=3
	IF(IOP.EQ.'EX') GO TO 900
	IF(I.EQ.2) GO TO 230
	IF(I.NE.0) GO TO 200
	WRITE(5,140)
140	FORMAT(/,' *** ERROR ON INPUT ***')
	WRITE(5,150) IOP
150	FORMAT(X,'''',A2,''' IS NOT A SUPPORTED OPTION.',/)
	IF(.NOT.CRT) GO TO 110
	CALL MARK(2,2,2)
	CALL WAITFR(2)
	GO TO 10
200	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	WRITE(5,210) 
210	FORMAT('$ENTER DEVICE - AAOO:   : ')
	READ(5,220) IND,DEV
220	FORMAT(Q,30A1)
	GO TO 290
230	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	WRITE(5,240)
240	FORMAT('$ENTER FILE SPEC : ')
	READ(5,250) ICNT,FN1
250	FORMAT(Q,30A1)
	IF(ICNT.LT.30) FN1(ICNT+1)=0
	CALL INIT (FDB)
	CALL PARSE(FDB,FN1,1,IER)
	CALL FIND (FDB,IER)
	CALL R50ASC(9,FDB(37),FN)
	CALL R50ASC(4,FDB(40),FT)
	IF(IER.EQ.-1) GO TO 270
	IFN =FDB(34)
	IFSN=FDB(35)
	ENCODE(5,260,DEV) FDB(47),FDB(48)
260	FORMAT(A2,O2,':')
	IND=5
	GO TO 305
270	WRITE(5,280) FDB(47),FDB(48),FN,FT,FDB(41)
280	FORMAT(' UNABLE TO FIND FILE NAME - ',A2,O2,':',9A1,'.',4A1,';',O6,
	1/,'$HIT RETURN TO CONTINUE : ')
	READ(5,220) ICNT,YN
	GO TO 10
290	DO 300 J=1,5
	INDXFN(J)=DEV(J)
300	CONTINUE
305	OPEN(UNIT=1,NAME=INDXFN,ACCESS='DIRECT',SHARED,READONLY,
	1ERR=310,TYPE='OLD')
	INFO=.TRUE.
	GO TO 330
310	WRITE(5,320) (INDXFN(J),J=1,22)
320	FORMAT(' ERROR ON INDEX FILE OPEN - NAME = ',22A1)
	STOP
330	CALL GETADR(IPRM,INBUF)
	IPRM(2)=512
	IPRM(3)=0
	IPRM(4)=0
	IPRM(5)=2
	CALL WTQIO("10400,1,1,,IOS,IPRM)
	IBMS1=INBUF(1)
	IF(IOSB(1).LT.0) IRE=.TRUE.
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	IF(I.EQ.3) GO TO 341
	WRITE(5,340)
340	FORMAT('$DO YOU WISH TO SEE HOME BLOCK DATA : ')
	READ(5,220) IC,YN
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	IF(YN.NE.'Y') GO TO 490
341	MAXFI(1)=MAXFIL
	IBMLI(1)=INBUF(3)
	IBMLI(2)=INBUF(2)
	WRITE(5,350) DEV,VOLNAM,VUIC,MAXF,IBMS,IBML,ICLFAC,PINF,DATMCR
350	FORMAT(25X,'VOLUME HOME BLOCK IMFORMATION',//,
	1' DEVICE : ',6A1,/,
	2' NAME   : ',12A1,/,
	3' UIC    : [',O3,',',O3,']',//,
	4' MAXIMUM # FILES ALLOWED      : ',I8,'.',/,
	5' INDEX FILE BIT MAP SIZE      : ',I8,'.',/,
	6' INDEX FILE BIT MAP LOCATION  : ',O8,/,
	7' STORAGE BIT MAP CLUSTER FAC  : ',I8,'.',/,
	8' DEFAULT # RETRIEVAL POINTERS : ',I8,'.',/,
	9' DEFAULT FILE EXTENSION       : ',I8,'.',//,
	1' DATE CREATED : ',2A1,'-',3A1,'-',2A1,/,
	2' TIME CREATED : ',2A1,':',2A1,':',3A1,/)
	ICH=0
	DO 380 J=1,255
	ICH=ICH+INBUF(J)
	IF(J.NE.29) GO TO 380
	IF(ICH.EQ.INBUF(30)) WRITE(5,360)
360	FORMAT(' CHECKSUM OF WORDS 0-28.  IS CORRECT')
	IF(ICH.NE.INBUF(30)) WRITE(5,370) ICH,INBUF(30)
370	FORMAT(' CHECKSUM OF WORDS 0-28.  IS BAD - CAL ',O6,' EXPECTED ',O6)
380	CONTINUE
	IF(ICH.EQ.INBUF(256)) WRITE(5,390)
390	FORMAT(' CHECKSUM OF WORDS 0-254. IS CORRECT')
	IF(ICH.NE.INBUF(256)) WRITE(5,400) ICH,INBUF(256)
400	FORMAT(' CHECKSUM OF WORDS 0-254. IS BAD - CAL ',O6,' EXPECTED ',O6)
	IF(IRE) WRITE(5,410) IOSB(1)
410	FORMAT(/,' *** NOTE - ERROR DURING READ - ERROR CODE = ',I4,' ***'
	1,//)
	WRITE(5,420)
420	FORMAT(//,'$HIT CARRIAGE RETURN TO CONTINUE (X TO RETURN TO MENU)',
	1' : ')
	READ(5,220) IQ,YN
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	IF(YN.EQ.'X') GO TO 10
	IF(I.EQ.3)    GO TO 10
490	GO TO (500,540,10),I
500	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	CALL GETADR(IPRM,INBUF)
	WRITE(5,510)
510	FORMAT('$ENTER FILE # AND FILE SEQUENCE # - OOOOO,OOOOO',
	1' (0 TO RETURN) : ')
	READ(5,520,ERR=530) IFN,IFSN
520	FORMAT(2O8)
	IF(IFN.EQ.0) GO TO 10
	GO TO 540
530	WRITE(5,140)
	IF(.NOT.CRT) GO TO 500
	CALL MARK(2,2,2)
	CALL WAITFR(2)
	CALL CLRP
	GO TO 500
540	IRE=.FALSE.
	IPRM(5)=2+IBMS1+IFN
	CALL WTQIO("10400,1,1,,IOS,IPRM)
	IF(IOSB(1).LT.0) IRE=.TRUE.
	CALL FHLS
	WRITE(5,550)
550	FORMAT(/,'$DO YOU WISH TO SEE MAPPING IMFORMATION : ')
	READ(5,220) ICNT,YN
	IF(YN.EQ.'Y') CALL MAPF
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	IF(YN.EQ.'Y'.OR.CRT) CALL FHLS
	WRITE(5,560)
560	FORMAT(/,'$DO YOU WISH TO COPY THE FILE : ')
	READ(5,220) ICNT,YN
	IF(YN.EQ.'Y') CALL COPY
	IF(I.EQ.1) GO TO 500
	GO TO 10
900	CALL DETACH(5)
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
1000	FORMAT(/////)
	CLOSE(UNIT=1)
	STOP
	END
	SUBROUTINE FHLS
	BYTE TCHC(2),FLAG,DEV(6),YN
	BYTE VOLNAM(12),VUIC(2),PINF(2),DATMCR(14),INDXFN(24)
	BYTE IOSB(4),INBUFB(512),FN(9),FT(4),PRO(4),PROT(16)
	BYTE BMFN(24)
	INTEGER BITMAP(256),TCH,IPRM(6),FVER,IBMLI(2),MAXFI(2)
	INTEGER IOS(2),BMBNI(2)
	INTEGER*4 IBML,MAXF,BMBN
	DIMENSION INBUF(256),INBUF1(256)
	LOGICAL*2 CRT,INFO,IRE,BMFO,EXT
	EQUIVALENCE (IOS,IOSB),(INBUF,INBUFB),(BMBNI,BMBN)
	EQUIVALENCE (TCHC,TCH),(IBML,IBMLI),(MAXFI,MAXF)
	EQUIVALENCE (INBUF,IBMS),(INBUF(4),MAXFIL),
	1(INBUF(5),ICLFAC),(INBUF(8),VOLNAM),(INBUF(16),VUIC),
	2(INBUF(23),PINF),(INBUF(31),DATMCR)
	COMMON INBUF,IBML,DEV,BITMAP,IOS,CRT,INFO,IRE,BMBN,BMFO,
	1BMFN,PRO,PROT,FN,YN,FT,IPRM,IFN,IFSN,INDXFN,IND
	COMMON /ASTDAT/FLAG
	DATA INDXFN/5*' ','[','0',',','0',']','I','N','D','E','X','F',
	1'.','S','Y','S',';','1',0,0/
	DATA BMFN  /5*' ','[','0',',','0',']','B','I','T','M','A','P',
	1'.','S','Y','S',';','1',0,0/
	DATA TCHC/"12,0/
	DATA PRO/'R','W','E','D'/
	IP=1
	DO 560 J=1,4
	DO 550 J1=1,4
	PROT((J-1)*4+J1)='.'
	IF(IAND(IP,INBUF(6)).EQ.0) PROT((J-1)*4+J1)=PRO(J1)
	IP=IP*2
550	CONTINUE
560	CONTINUE
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	CALL R50ASC(9,INBUF(24),FN)
	CALL R50ASC(4,INBUF(27),FT)
	R ='*** '
	R1='MISM'
	R2='ATCH'
	R3=' ***'
	IF(INBUF(3).NE.IFSN) GO TO 569
	R ='    '
	R1=R
	R2=R1
	R3=R2
569	WRITE(5,570) FN,FT,INBUF(28),INBUF(2),INBUF(3),IFSN,R,R1,R2,R3,
	1INBUFB(10),INBUFB(9),PROT,INBUF(29),(INBUFB(J),J=59,84)
570	FORMAT(28X,'FILE HEADER IMFORMATION',//,
	1' NAME         : ',9A1,'.',4A1,';',O5,/,
	2' FILE #       :    ',O6,/,
	3' SEQUENCE #   :    ',O6,'  REQUESTED : ',O6,5X,4A4,/,
	4' UIC          : [',O3,',',O3,']',/,
	5' PROTECT CODE : [',4A1,','4A1,',',4A1,',',4A1,']',/,
	6' REVISION #   : ',O6,/,
	7' DATE REVISED : ',2A1,'-',3A1,'-',2A1,5X,2A1,':',2A1,':',2A1,/,
	9' DATE CREATED : ',2A1,'-',3A1,'-',2A1,5X,2A1,':',2A1,':',2A1,/)
	J=INBUFB(15)
	GO TO (580,600,620),J
580	WRITE(5,590) INBUF(9)
590	FORMAT(' FIXED LENGTH RECORDS           - SIZE  : ',O6,' BYTES')
	GO TO 640
600	WRITE(5,610) INBUF(9)
610	FORMAT(' VARIABLE LENGTH RECORDS - LARGEST IS   : ',O6,' BYTES')
	GO TO 640
620	WRITE(5,630) INBUF(9)
630	FORMAT(' SEQUENCED RECORDS              - SIZE  : ',O6,' BYTES')
640	IBMLI(1)=INBUF(11)
	IBMLI(2)=INBUF(10)
	WRITE(5,650) IBML
650	FORMAT(' HIGHEST VIRTUAL BLOCK NUMBER ALLOCATED : ',O6)
	IBMLI(1)=INBUF(13)
	IBMLI(2)=INBUF(12)
	WRITE(5,660) IBML
660	FORMAT(' VIRTUAL BLOCK CONTAINING END-OF-FILE   : ',O6)
	J=INBUFB(13)
	IF(IAND(J,"200).NE.0) WRITE(5,810)
810	FORMAT(' 	FILE IS CONTIGUOUS')
	IF(IAND(J,"100).NE.0) WRITE(5,820)
820	FORMAT(' 	FILE IS IMPROPERLY CLOSED')
	J=INBUFB(14)
	IF(IAND(J,"200).NE.0) WRITE(5,830)
830	FORMAT(' 	FILE IS MARKED FOR DELETE')
	IF(IAND(J,"100).NE.0) WRITE(5,840)
840	FORMAT(' 	BAD DATA BLOCK IN FILE')
	ICH=0
	DO 850 J=1,255
850	ICH=ICH+INBUF(J)
	IF(ICH.EQ.INBUF(256)) WRITE(5,390)
	IF(ICH.NE.INBUF(256)) WRITE(5,400) ICH,INBUF(256)
390	FORMAT(/,' CHECKSUM OF WORDS 0-254. IS CORRECT')
400	FORMAT(/,' CHECKSUM OF WORDS 0-254. IS BAD - CAL ',O6,' EXPECTED ',
	1O6)
	IBN=IFN/4096
	IF(IFN-4096*IBN.EQ.0) IBN=IBN-1
	IWN=(IFN-4096*IBN)/16
	IF(IFN-4096*IBN-16*IWN.EQ.0) IWN=IWN-1
	IBTN=IFN-4096*IBN-IWN*16
	IMW=2**(IBTN-1)
	CALL GETADR(IPRM,BITMAP)
	IPRM(5)=3+IBN
	CALL WTQIO("10400,1,1,,IOS,IPRM)
	IBN=IBN+1
	IWN=IWN+1
	IF(IAND(BITMAP(IWN),IMW).NE.0) WRITE(5,410) IBN,IWN*2-2,IMW
410	FORMAT(' HEADER FILE BIT MAP CHECK OKAY : BLK-',I3,' ADR-',O3,
	1' MWD-',O6)
	IF(IAND(BITMAP(IWN),IMW).EQ.0) WRITE(5,420) IBN,IWN*2-2,IMW
420	FORMAT(' HEADER FILE BIT MAP CHECK BAD : BLK-',I3,' ADR-',O3,
	1' MWD-',O6,//,' *** FILE HAS BEEN DELETED OR HEADER BITMAP',
	2' CORRUPT ***')
	RETURN
1000	FORMAT(/////)
	END
	SUBROUTINE MAPF
	BYTE TCHC(2),FLAG,DEV(6),YN
	BYTE VOLNAM(12),VUIC(2),PINF(2),DATMCR(14),INDXFN(24)
	BYTE IOSB(4),INBUFB(512),FN(9),FT(4),PRO(4),PROT(16)
	BYTE BMFN(24),YN1,BITMB(512),C
	INTEGER BITMAP(256),TCH,IPRM(6),FVER,IBMLI(2),MAXFI(2)
	INTEGER IOS(2),BMBNI(2)
	INTEGER*4 IBML,MAXF,BMBN,ID,ID1,TOTB,BMBN1
	DIMENSION INBUF(256),INBUF1(256)
	LOGICAL*2 CRT,INFO,IRE,BMFO,EXT
	EQUIVALENCE (BITMAP,BITMB)
	EQUIVALENCE (IOS,IOSB),(INBUF,INBUFB),(BMBNI,BMBN)
	EQUIVALENCE (TCHC,TCH),(IBML,IBMLI),(MAXFI,MAXF)
	EQUIVALENCE (INBUF,IBMS),(INBUF(4),MAXFIL),
	1(INBUF(5),ICLFAC),(INBUF(8),VOLNAM),(INBUF(16),VUIC),
	2(INBUF(23),PINF),(INBUF(31),DATMCR)
	COMMON INBUF,IBML,DEV,BITMAP,IOS,CRT,INFO,IRE,BMBN,BMFO,
	1BMFN,PRO,PROT,FN,YN,FT,IPRM,IFN,IFSN,INDXFN,IND
	COMMON /ASTDAT/FLAG
	DATA INDXFN/5*' ','[','0',',','0',']','I','N','D','E','X','F',
	1'.','S','Y','S',';','1',0,0/
	DATA BMFN  /5*' ','[','0',',','0',']','B','I','T','M','A','P',
	1'.','S','Y','S',';','1',0,0/
	DATA TCHC/"12,0/
	DATA PRO/'R','W','E','D'/
	DATA ID1/4096/
	EXT=.FALSE.
	TOTB=0
	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
	DO 10 I=1,5
10	BMFN(I)=DEV(I)
	OPEN(UNIT=2,NAME=BMFN,ACCESS='DIRECT',TYPE='OLD',SHARED,READONLY,
	1ERR=20)
	GO TO 40
20	WRITE(5,30)
30	FORMAT(' *** ERROR ON BITMAP OPEN ***')
	CLOSE(UNIT=1)
	STOP
40	WRITE(5,50)
50	FORMAT(36X,'FILE MAP',//,' ENTRY #',5X,'COUNT',5X,'LOGICAL',
	1' BLOCK #',5X,'BMP BLK #',5X,'ADR',5X,'MASK WORD',/)
	CALL GETADR(IPRM,BITMAP)
	IPRT=0
60	IP=52
	NP=INBUFB(101)/2
	IBN1=0
	DO 200 J1=1,NP
	IC=INBUFB(IP*2)
	IC=IAND(IC,"377)+1
	TOTB=TOTB+IC
	BMBNI(2)=IAND(INBUF(IP),"377)
	BMBNI(1)=INBUF(IP+1)
	C=' '
	IF(BMBN.EQ.BMBN1.AND.J1.NE.1) C='C'
	DO 100 J2=1,IC
	BMBN=BMBN+1
	IBN=BMBN/4096
	ID=ID1*IBN
	IF(BMBN-ID.EQ.0) IBN=IBN-1
	ID=ID1*IBN
	IWN=(BMBN-ID)/16
	IF(BMBN-ID-16*IWN.EQ.0) IWN=IWN-1
	IBTN=BMBN-ID-16*IWN
	IMW=2**(IBTN-1)
	IBN=IBN+2
	IWN=IWN+1
	IF(J2.NE.1) GO TO 63
	IF(CRT) IPRT=IPRT+1
	IF(IPRT.LT.18) GO TO 64
	WRITE(5,71)
	READ(5,72) YN1
	IF(YN1.EQ.'X') GO TO 211
	CALL CLRP
	WRITE(5,50)
	IPRT=0
64	WRITE(5,65) J1,IC,BMBN-1,C,IBN,IWN*2-2,IMW
65	FORMAT(X,I5,6X,O5,5X,O10,X,1A1,8X,O7,7X,O4,5X,O8)
63	IF(IBN1.EQ.IBN) GO TO 70
	IPRM(5)=IBN
	IBN1=IBN
	CALL WTQIO("10400,2,2,,IOS,IPRM)
	IF(IOSB(1).GT.0) GO TO 70
	WRITE(5,66) IOSB(1),IPRM(5)
66	FORMAT(' ***ERROR ON READ - STATUS : ',I3,' BLOCK # ',O6)
70	IF(IAND(IMW,BITMAP(IWN)).EQ.0) GO TO 100
	IF(CRT) IPRT=IPRT+1
	IF(IPRT.LT.18) GO TO 79
	WRITE(5,71)
71	FORMAT(/,'$MORE - HIT RETURN TO CONTINUE (X-EXIT) : ')
	READ(5,72) YN1
72	FORMAT(1A1)
	IF(YN1.EQ.'X') GO TO 211	
	CALL CLRP
	WRITE(5,50)
	IPRT=0
79	WRITE(5,80) BMBN-1,IPRM(5),IWN*2-2,IMW
80	FORMAT(' BAD BITMAP CHECK - LBN ',O8,10X,O7,7X,O4,5X,O8)
100	CONTINUE
	BMBN1=BMBN
	IP=IP+2
200	CONTINUE
	IF(INBUF(48).EQ.0) GO TO 201
	CALL GETADR(IPRM,INBUF)
	IPRM(5)=INBUF(48)
	CALL WTQIO("10400,1,1,,IOS,IPRM)
	CALL GETADR(IPRM,BITMAP)
	EXT=.TRUE.
	GO TO 60
201	WRITE(5,202) TOTB
202	FORMAT(/,' MAP LIST COMPLETE - ',O8,' BLOCKS VERIFIED',/,
	1'$HIT RETURN TO CONTINUE : ')
	READ(5,72) YN1
210	FORMAT(I1)
211	CLOSE(UNIT=2)
	IPRM(5)=IFN
	CALL GETADR(IPRM,INBUF)
	IF(.NOT.EXT) GO TO 900
	CALL WTQIO("10400,1,1,,IOS,IPRM)
	EXT=.FALSE.
900	RETURN
1000	FORMAT(/////)
	END
	SUBROUTINE COPY
	BYTE TCHC(2),FLAG,UIC(2),FNAME(20),FEXT(6),DEV(6),YN
	BYTE VOLNAM(12),VUIC(2),PINF(2),DATMCR(14),INDXFN(24)
	BYTE IOSB(4),INBUFB(512),FN(9),FT(4),PRO(4),PROT(16)
	BYTE BMFN(24),FN1(30),IDVB(2),YN1
	INTEGER BITMAP(256),TCH,IPRM(6),FVER,IBMLI(2),MAXFI(2)
	INTEGER IOS(2),BMBNI(2),FDDB(7),IRCI(2)
	INTEGER*4 IBML,MAXF,BMBN,IRC
	DIMENSION INBUF(256),INBUF1(256)
	LOGICAL*2 CRT,INFO,IRE,BMFO,EXT
	EQUIVALENCE (IDV,IDVB),(IRC,IRCI)
	EQUIVALENCE (IOS,IOSB),(INBUF,INBUFB),(BMBNI,BMBN)
	EQUIVALENCE (TCHC,TCH),(IBML,IBMLI),(MAXFI,MAXF)
	EQUIVALENCE (INBUF,IBMS),(INBUF(4),MAXFIL),
	1(INBUF(5),ICLFAC),(INBUF(8),VOLNAM),(INBUF(16),VUIC),
	2(INBUF(23),PINF),(INBUF(31),DATMCR)
	COMMON INBUF,IBML,DEV,BITMAP,IOS,CRT,INFO,IRE,BMBN,BMFO,
	1BMFN,PRO,PROT,FN,YN,FT,IPRM,IFN,IFSN,INDXFN,IND
	COMMON /ASTDAT/FLAG
	DATA INDXFN/5*' ','[','0',',','0',']','I','N','D','E','X','F',
	1'.','S','Y','S',';','1',0,0/
	DATA BMFN  /5*' ','[','0',',','0',']','B','I','T','M','A','P',
	1'.','S','Y','S',';','1',0,0/
	DATA TCHC/"12,0/
	DATA PRO/'R','W','E','D'/
	IRC=0
10	IF(CRT) CALL CLRP
	IF(.NOT.CRT) WRITE(5,1000)
15	WRITE(5,20)
20	FORMAT('$ENTER FILE SPEC : ')
	READ(5,30) ICNT,FN1
30	FORMAT(Q,30A1)
	IF(ICNT.NE.0) GO TO 35
	ENCODE(21,910,FN1) FN,FT,INBUF(28)
910	FORMAT(9A1,'.',4A1,';',O6)
	ICNT=21
	WRITE(5,1010) (FN1(J),J=1,21)
1010	FORMAT(' FILE NAME = ',21A1,/)
35	IF(ICNT.LT.30) FN1(ICNT+1)=0
	OPEN(UNIT=3,NAME=FN1,ACCESS='DIRECT',TYPE='NEW',RECORDSIZE=128,
	1EXTENDSIZE=1,ERR=40)
	GO TO 60
40	WRITE(5,50) (FN1(J),J=1,ICNT)
50	FORMAT(' *** ERROR ON OPEN - FILE = ',<ICNT>A1)
	IF(.NOT.CRT) GO TO 15
	CALL MARK(2,2,2)
	CALL WAITFR(2)
	GO TO 10
60	IDN=0
	IP=1
	DO 70 I=1,IND
	IF(IP.GT.2) GO TO 80
	IF(DEV(I).EQ.' ') GO TO 70
	IDVB(IP)=DEV(I)
	IP=IP+1
70	CONTINUE
80	IF(I.NE.IND+1) GO TO 90
	IDV='SY'
	IDN=0
	GO TO 200
90	IF(DEV(I).EQ.':') GO TO 200
	J=1
	IF(DEV(I+1).NE.':') J=2
	DECODE(J,100,DEV(I)) IDN
100	FORMAT(I<J>)
200	CALL ASNLUN(4,IDV,IDN,IDS)
	IF(IDS.GT.0) GO TO 300
	WRITE(5,210) IDV,IDN,IDS
210	FORMAT(' *** ERROR ON DEVICE ASSIGNMENT FOR INPUT : ',I2,O<J>,':',
	1'  IDS = ',I5)
	CLOSE(UNIT=3)
	RETURN
300	CALL GETADR(IPRM,BITMAP)
	IP=52
	NP=INBUFB(101)/2
	DO 500 J1=1,NP
	IC=INBUFB(IP*2)
	IC=IAND(IC,"377)+1
	BMBNI(1)=INBUF(IP+1)
	BMBNI(2)=IAND(INBUF(IP),"377)
	DO 400 I=1,IC
	IPRM(5)=BMBNI(1)
	IPRM(4)=BMBNI(2)
	BMBN=BMBN+1
	CALL WTQIO("1000,4,4,,IOS,IPRM)
	IF(IOSB(1).GT.0) GO TO 350
	WRITE(5,310) IOSB(1),BMBN-1,IRC+1
310	FORMAT(' ERROR ',I5,' LOGICAL BLOCK # ',O10,' VIRTUAL BLOCK # ',O10,/,
	1'$HIT CARRIAGE RETURN TO CONTINUE (X-TO TERMINATE COPY) : ')
	READ(5,320) YN1
320	FORMAT(1A1)
	IF(YN1.EQ.'X') GO TO 900
350	IRC=IRC+1
	WRITE(3'IRC,ERR=750) BITMAP
400	CONTINUE
	IP=IP+2
500	CONTINUE
600	IF(INBUF(48).EQ.0) GO TO 700
	CALL GETADR(IPRM,INBUF)
	IPRM(5)=INBUF(48)
	CALL WTQIO("10400,1,1,,IOS,IPRM)
	EXT=.TRUE.
	GO TO 300
700	IPRM(5)=IFN
	CALL GETADR(IPRM,INBUF)
	IF(.NOT.EXT) GO TO 800
	CALL WTQIO("10400,1,1,,IOS,IPRM)
	EXT=.FALSE.
	GO TO 800
750	IRC=IRC-1
800	BMBNI(1)=INBUF(11)
	BMBNI(2)=INBUF(10)
	DO 810 I=1,7
810	FDDB(I)=INBUF(I+7)
	IF(BMBN.EQ.IRC) GO TO 850
	FDDB(3)=IRCI(2)
	FDDB(4)=IRCI(1)
	FDDB(5)=FDDB(3)
	FDDB(6)=FDDB(4)
850	CALL FBSET(FDDB)
900	CLOSE(UNIT=4)
	CLOSE(UNIT=3)
	RETURN
1000	FORMAT(/////)
	END