C VAX/VMS Executable Image File Disassembler, V0.0 (26-MAY-1982)
C	rebuilt to V1.0 on 6-JAN-1984
C	rebuilt to V2.0 on 6-FEB-1986
C	rebuilt to V3.0 on 30-JUN-1986
C	rebuilt to V3.1 on 21-JUL-1986
C	rebuilt to V3.2 on 24-JUL-1986
C	rebuilt to V3.3 on 28-JUL-1986
C	rebuilt to V3.4 on 6-NOV-1986
C	rebuilt to V3.5 on 18-DEC-1986
C	rebuilt to V3.6 on 3-FEB-1987 (fix typos in table processing, stack ISD,
C					undef and HALT opcode processing)
C	rebuilt to V3.7 on 6-FEB-1987 (add .ADDRESS fixup processing, add GST
C					dumping, fix some RMS bugs)
C	rebuilt to V4.0 on 1-APR-1987 (add extended symbol table processing,
C					recognition of shareable image transfer
C					vectors, P-sect table analysis, change
C					format of made-up symbol names, fix bugs
C					in DST analysis, fix filename source
C					for .SYM file read, add logic to detect
C					some condition code symbols, optimize)
C
C	written by Andrew Pavlin,
C		   General Electric Company
C		   Military Electronic Systems Organization
C		   Syracuse, NY 13221
C
C    This program, implemented as a VMS foreign command, will accept
C  an executable or shareable image file (filetype assumed to be .EXE),
C  and generate an ASCII text file of filetype .MAR containing an assembly
C  source listing of the contents of the executable or shareable image.
C  Symbols will be extracted from any debugger or global symbol tables
C  embedded in the image file and used to label the source listing;
C  symbols will be created by the program to fill any undefined names.
C
C**********************************************************************
C
C  declare variables
C
      IMPLICIT NONE
C
      INCLUDE 'DISMSYMTBL.INC'
      INCLUDE 'DISMMODTBL.INC'
      INCLUDE 'DISMLINTBL.INC'
      INCLUDE 'DISMISDTBL.INC'
      INCLUDE 'DISMMISC.INC'
C
      BYTE HDR_BUF(0:8191)
      BYTE TAB,REC_TYP,REC_SUBTYP,form_feed,FACILITY_NAMLEN, MSG_NAMLEN,
     +		DISPL_BYT
      CHARACTER*1 DTYP_C(0:15)
      CHARACTER*3 C_ROP_CODES(0:31), C_FAB_FAC_CODES(0:7),
     +		C_FAB_FOP_CODES(0:30), C_FAB_RAT_CODES(0:3),
     +		C_FAB_SHR_CODES(0:6)
      CHARACTER*4 PROT_NAME(0:15), ADAPTER_NAME(0:6)
      CHARACTER*5 IMG_LNK_TYP(1:3) /'BPA','ALIAS','CLI'/, 
     +		C_FAB_RFM_CODES(0:6)
      CHARACTER*6 BLOCK_TYPE(73), C_ISDTYP(0:4), C_MATCH_TYPE(0:3)
      CHARACTER*7 LANGUAGE_NAME(0:10)
      CHARACTER*8 STR_DELIM, SPECIAL_MACRO(20)
      CHARACTER*23 DT_STR, FACILITY_NAM
      CHARACTER*16 EDIT_NAM(17)
      CHARACTER*31 ROUTINE_NAME, BLOCK_NAME
      CHARACTER*64 OUT_FIL, FACILITY_BUF
      CHARACTER*256 CMD_LIN
      CHARACTER*512 S_TMP, MESSAGE_BUF
      INTEGER*2 LN,LN2,LN3,LN4, FACILITY_NUMBER, DISPL_WRD
      INTEGER*4 I,J,K,ADDR,OP_MODE,I_FLT(4),EDIT_MASK(17),EDIT_OPC(17),
     +	EDIT_ARG(17),DTYP_SIZE(0:25),LIBRARY_INDEX, I2, I3, I8, I9,
     +	ICODE, OFFSET_VEC(0:1), CURRENT_LINE, CURRENT_STMT, CURRENT_INCR,
     +	CURRENT_PC, DBG_RECS, AUX_SYM_TBL(-1:256), MSG_USERVALUE,
     +	MSG_FAOCOUNT,	MSG_NUMFAC, MSG_FACDESCR(4,30), MOD_PTR
      LOGICAL*1 ISD_PRESENT,OK,OK2, CURRENT_STMT_MODE, CURRENT_MARK,
     +	DTYP_CONTINUE(0:25),	LLV_CODEMODE
      REAL*4 X_FLT
      REAL*8 X_DFL	! GFL has to be done by a separate subroutine
      REAL*16 X_HFL
      EXTERNAL RMS$_EOF,DISM__ISDTBLOVF,DISM__INVINITAB,
     +	DISM__UNKIMGTYP,DISM__FORTIORD,DISM__BADSYSSTB,
     +	DISM__BADSHRIMG,DISM__INVOPCODE,DISM__BADUSRSFL,
     +	DISM__SYMTBLOVF,DISM__INVSYMSRC,DISM__UNRECVEC,
     +	DISM__COMPATIMG,DISM__NONSTDIMG,DISM__NOIMGHDR,
     +	DISM__CORDTSTRUC,DISM__DIFINTNAM
      EXTERNAL	SS$_BADIMGHDR,	DYN$C_DPT,	DYN$C_DDB,	DYN$C_UCB,
     +		DYN$C_CRB,	DYN$C_IDB
      INTEGER*4 DISM_INSTR,	ANALYZE_SYM_REC,	FIND_P2_SYMBOL,
     +		CONVERT_F_FLOAT,	CONVERT_D_FLOAT,
     +		CONVERT_G_FLOAT,	CONVERT_H_FLOAT
      EXTERNAL FIX_BUFR_OVRFL,FIX_BUF_1,FIX_BUF_3, DISM_INSTR,
     +		ANALYZE_SYM_REC,	FIND_P2_SYMBOL,
     +		CONVERT_F_FLOAT,	CONVERT_D_FLOAT,
     +		CONVERT_G_FLOAT,	CONVERT_H_FLOAT
      INTEGER*4 LIB$INIT_TIMER,	LIB$GET_FOREIGN,	LIB$FFS,
     +		LBR$INI_CONTROL,	LBR$OPEN,	LBR$LOOKUP_KEY,
     +		LBR$GET_RECORD,		LBR$CLOSE,	SYS$ADJWSL,
     +		STR$FIND_FIRST_NOT_IN_SET,	LIB$SHOW_TIMER
      EXTERNAL	LIB$INIT_TIMER,	LIB$GET_FOREIGN,	LIB$FFS,
     +		LBR$INI_CONTROL,	LBR$OPEN,	LBR$LOOKUP_KEY,
     +		LBR$GET_RECORD,		LBR$CLOSE,	SYS$ADJWSL,
     +		STR$FIND_FIRST_NOT_IN_SET,	LIB$SHOW_TIMER
      COMMON/CMDLINPRS/CMD_LIN, OUT_FIL
      DATA TAB/9/, form_feed/12/
      DATA DTYP_C/'B','B','W','L','Q','F','D','G','H','B','B','B','B',
     +	'B','B','O'/
      DATA C_ROP_CODES/'ASY','TPT','REA','RRL','UIF','MAS','FDL','HSH',
     +	'EOF','RAH','WBH','BIO','LV2','LOA','LIM','***','LOC','WAT',
     +	'ULK','RLK','NLK','KGE','KGT','NXR','RNE','TMO','CVT','RNF',
     +	'ETO','PTA','PMT','CCO'/
      DATA C_FAB_FAC_CODES/'PUT','GET','DEL','UPD','TRN','BIO','BRO',
     +	'EXE'/
      DATA C_FAB_FOP_CODES/'ASY','MXV','SUP','TMP','TMD','DFW','SQO',
     +	'RWO','POS','WCK','NEF','RWC','DMO','SPL','SCF','DLT','NFS',
     +	'UFO','PPF','INP','CTG','CBT','***','RCK','NAM','CIF','***',
     +	'ESC','TEF','OFP','KFO'/
      DATA C_FAB_RAT_CODES/'FTN','CR','PRN','BLK'/
      DATA C_FAB_RFM_CODES/'UDF','FIX','VAR','VFC','STM','STMLF',
     +		'STMCR'/
      DATA C_FAB_SHR_CODES/'PUT','GET','DEL','UPD','MSE','NIL','UPI'/
      DATA C_ISDTYP/'NORMAL','SHRFXD','PRVFXD','SHRPIC','PRVPIC'/
      DATA C_MATCH_TYPE/'MATALL','MATEQU','MATLEQ','unsupt'/
      DATA ADAPTER_NAME/'MBA','UBA','DR','MPM','CI','NULL','BDA'/
      DATA BLOCK_TYPE/'ADP','ACB','AQB','CEB','CRB','DDB','FCB','FRK',
     +		      'IDB','IRP','LOG','PCB','PQB','RVT','TQE','UCB',
     +		      'VCB','WCB','BUFIO','TYPAHD','GSD','MVL','NET',
     +		      'KFE','MTL','BRDCST','CXB','NDB','SSB','DPT','JPB',
     +		      'PBH','PDB','PIB','PFL','JNLWCB','PTR','KFRH','DCCB',
     +		      'EXTGSD','SHMGSD','SHB','MBX','IRPE','SLAVCEB',
     +		      'SHMCEB','JIB','TWP','RBM','VCA','CDB','LPD','LKB',
     +		      'RSB','LKID','RSHT','CDRP','ERP','CIDG','CIMSG','XWB',
     +		      'WQE','ACL','LNM','FLK','RIGHTSLIST','KFD','KFPB',
     +		      'CIA','PMB','PFB','CHIP','ORB'/
      DATA STR_DELIM/'"/\%#@'''/
      DATA LANGUAGE_NAME/'MACRO32','FORTRAN','BLISS','COBOL','BASIC',
     +			 'PL/I','Pascal','C','RPG II','Ada','unknown'/
      DATA DTYP_SIZE/4,1,2,4,8,4,8,8,16,1,1,1,1,1,1,16,4*1,
     +				1,44,42,1,1,4/
      DATA DTYP_CONTINUE/16*.TRUE.,4*.FALSE.,.FALSE.,.FALSE.,.FALSE.,
     +				.TRUE.,.TRUE.,.TRUE./
      DATA EDIT_MASK/'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,
     +	'FF'X,'FF'X,'FF'X,'FF'X,'FF'X,'F0'X,'F0'X,'F0'X,0/
      DATA EDIT_OPC/0,1,2,3,4,'40'X,'41'X,'42'X,'43'X,'44'X,'45'X,
     +	'46'X,'47'X,'80'X,'90'X,'A0'X,0/
      DATA EDIT_ARG/0,0,0,0,0,3,3,3,3,3,2,2,2,1,1,1,0/
      DATA EDIT_NAM/'EO$END','EO$END_FLOAT','EO$CLEAR_SIGNIF',
     +	'EO$SET_SIGNIF','EO$STORE_SIGN','EO$LOAD_FILL','EO$LOAD_SIGN',
     +	'EO$LOAD_PLUS','EO$LOAD_MINUS','EO$INSERT','EO$BLANK_ZERO',
     +	'EO$REPLACE_SIGN','EO$ADJUST_INPUT','EO$FILL','EO$MOVE',
     +	'EO$FLOAT',' '/
      DATA PROT_NAME/'n/a','rsrv','KW','KR','UW','EW','ERKW','ER','SW',
     +	'SREW','SRKW','SR','URSW','UREW','URKW','UR'/
      DATA SPECIAL_MACRO/'$TPADEF','$TPADEF','$TPADEF','$DVIDEF',
     +			 '$JPIDEF','$QUIDEF','$SYIDEF','$SJCDEF',
     +			 12*' '/
      EQUIVALENCE (I_FLT(1),X_FLT,X_DFL,X_HFL)
      EQUIVALENCE (FACILITY_BUF(1:2),	FACILITY_NUMBER),
     +		  (FACILITY_BUF(3:3),	FACILITY_NAMLEN),
     +		  (FACILITY_BUF(4:4),	FACILITY_NAM(1:1))
      EQUIVALENCE (MESSAGE_BUF(1:4),	MSG_USERVALUE),
     +		  (MESSAGE_BUF(5:8),	MSG_FAOCOUNT),
     +		  (MESSAGE_BUF(9:9),	MSG_NAMLEN)
      INCLUDE '($FSCNDEF)'
      INCLUDE '($JPIDEF)'
      INCLUDE '($LBRDEF)'
C
      STRUCTURE /IHD/
	INTEGER*2 W_SIZE
	INTEGER*2 W_ACTIVOFF
	INTEGER*2 W_SYMDBGOFF
	INTEGER*2 W_IMGIDOFF
	INTEGER*2 W_PATCHOFF
	BYTE %FILL (2)
	INTEGER*2 W_MAJORID
	INTEGER*2 W_MINORID
	BYTE	  B_HDRBLKCNT
	BYTE	  B_IMGTYPE
	BYTE %FILL (2)
	INTEGER*4 Q_PRIVREQS(2)
	INTEGER*2 W_IOCHANCNT
	INTEGER*2 W_IMGIOCNT
	INTEGER*4 L_LNKFLAGS
	INTEGER*4 L_IDENT
	INTEGER*4 L_SYSVER
	INTEGER*4 L_IAFVA
      END STRUCTURE
      INTEGER*4 IHD$S_SIZE
      PARAMETER(IHD$S_SIZE=48)
      RECORD /IHD/ IHD,	SHR_IHD
      STRUCTURE /IHA/
	INTEGER*4 L_TFRADR(3)
	INTEGER*4 %FILL
      END STRUCTURE
      INTEGER*4 IHA$S_SIZE
      PARAMETER(IHA$S_SIZE=16)
      RECORD /IHA/ IHA
      STRUCTURE /IHI/
	BYTE	  B_IMGNAMLEN
	UNION
	  MAP
	    CHARACTER*39 T_IMGNAM
	    BYTE	 B_IMGIDLEN
	    CHARACTER*15 T_IMGID
	    INTEGER*4	 Q_LINKTIME(2)
	    BYTE	 B_LINKIDLEN
	    CHARACTER*15 T_LINKID
	  END MAP
	  MAP
	    CHARACTER*15 T_IMGNAM_V3
	    BYTE	 B_IMGIDLEN_V3
	    CHARACTER*15 T_IMGID_V3
	    INTEGER*4	 Q_LINKTIME_V3(2)
	    BYTE	 B_LINKIDLEN_V3
	    CHARACTER*15 T_LINKID_V3
	  END MAP
	END UNION
      END STRUCTURE
      INTEGER*4 IHI$S_SIZE,	IHI$S_SIZE_V3
      PARAMETER(IHI$S_SIZE=80,
     +		IHI$S_SIZE_V3=50)
      RECORD /IHI/ IHI
      STRUCTURE /IHP/
	INTEGER*4 L_ECO1
	INTEGER*4 L_ECO2
	INTEGER*4 L_ECO3
	INTEGER*4 L_ECO4
	INTEGER*4 L_RW_PATSIZ
	INTEGER*4 L_RW_PATADR
	INTEGER*4 L_RO_PATSIZ
	INTEGER*4 L_PATADR
	INTEGER*4 L_PATCOMTXT
	INTEGER*4 Q_PATDATE(2)
      END STRUCTURE
      INTEGER*4 IHP$S_SIZE
      PARAMETER(IHP$S_SIZE=44)
      RECORD /IHP/ IHP
      STRUCTURE /IHS/
	INTEGER*4 L_DSTVBN
	INTEGER*4 L_GSTVBN
	INTEGER*2 W_DSTBLKS
	INTEGER*2 W_GSTRECS
      END STRUCTURE
      INTEGER*4 IHS$S_SIZE
      PARAMETER(IHS$S_SIZE=12)
      RECORD /IHS/ IHS, SHR_IHS
      STRUCTURE /IAF/
	INTEGER*4 L_IAFLINK
	INTEGER*4 L_FIXUPLNK
	INTEGER*2 W_SIZE
	INTEGER*2 W_FLAGS
	INTEGER*4 L_G_FIXOFF
	INTEGER*4 L_DOTADROFF
	INTEGER*4 L_CHGPRTOFF
	INTEGER*4 L_SHLSTOFF
	INTEGER*4 L_SHRIMGCNT
	INTEGER*4 L_SHREXTRA
	INTEGER*4 L_PERMCTX
	BYTE	  %FILL (24)
      END STRUCTURE
      INTEGER*4 IAF$M_SHR
      PARAMETER(IAF$M_SHR='1'X)
      INTEGER*4 IAF$S_SIZE
      PARAMETER(IAF$S_SIZE=64)
      RECORD /IAF/ IAF
      STRUCTURE /SHL/
	INTEGER*4 L_BASEVA
	INTEGER*4 L_SHLPTR
	INTEGER*4 L_IDENT
	INTEGER*4 L_PERMCTX
	BYTE	  B_SHL_SIZE
	BYTE	  %FILL (7)
	BYTE	  B_IMGNAMLEN
	CHARACTER*39 T_IMGNAM
      END STRUCTURE
      INTEGER*4 SHL$S_SIZE,	SHL$S_SIZE_V3
      PARAMETER(SHL$S_SIZE=64,
     +		SHL$S_SIZE_V3=56)
      RECORD /SHL/ FIX_SHL(0:15)
      STRUCTURE /DPT/
	INTEGER*4 %FILL (2)	! FLINK, BLINK
	INTEGER*2 W_SIZE
	BYTE	  B_TYPE
	BYTE	  %FILL		! REFC
	BYTE	  B_ADPTYPE
	BYTE	  B_FLAGS
	INTEGER*2 W_UCBSIZE
	INTEGER*2 W_INITTAB
	INTEGER*2 W_REINITTAB
	INTEGER*2 W_UNLOAD
	INTEGER*2 W_MAXUNITS
	INTEGER*2 W_VERSION
	INTEGER*2 W_DEFUNITS
	INTEGER*2 W_DELIVER
	INTEGER*2 W_VECTOR
	BYTE	  B_NAMELEN
	CHARACTER*11 T_NAME
      END STRUCTURE
      INTEGER*4 DPT$S_SIZE
      PARAMETER(DPT$S_SIZE=44)
      RECORD /DPT/ DPT
      STRUCTURE /DDT/
	INTEGER*4 L_START
	INTEGER*4 L_UNSOLINT
	INTEGER*4 L_FDT
	INTEGER*4 L_CANCEL
	INTEGER*4 L_REGDUMP
	INTEGER*2 W_DIAGBUF
	INTEGER*2 W_ERRORBUF
	INTEGER*4 L_UNITINIT
	INTEGER*4 L_ALTSTART
	INTEGER*4 L_MNTVER
	INTEGER*4 L_CLONEDUCB
	INTEGER*2 W_FDTSIZE
	INTEGER*2 %FILL
	INTEGER*4 L_MNTV_SSSC
	INTEGER*4 L_MNTV_FOR
	INTEGER*4 L_MNTV_SQD
      END STRUCTURE
      INTEGER*4 DDT$S_SIZE
      PARAMETER(DDT$S_SIZE=56)
      RECORD /DDT/ DDT
      STRUCTURE /DPT_STORE/
	BYTE	  B_STRUCTYPE
	BYTE	  B_STRUCOFFSET
	BYTE	  B_OPERATION
	UNION
	  MAP
	    BYTE	B_BYTEVAL
	  END MAP
	  MAP
	    INTEGER*2	W_WORDVAL
	  END MAP
	  MAP
	    INTEGER*4	L_LONGVAL
	  END MAP
	  MAP
	    INTEGER*4	L_FIELDVAL
	    BYTE	B_FIELDPOS
	    BYTE	B_FIELDSIZ
	  END MAP
	END UNION
      END STRUCTURE
      INTEGER*4 DPT_STORE$S_SIZE
      PARAMETER(DPT_STORE$S_SIZE=9)
      RECORD /DPT_STORE/ DPT_STORE
      INTEGER*4 DDT_ADR
      STRUCTURE /PLV/
	INTEGER*4 L_TYPE
	INTEGER*4 L_VERSION
	UNION
	  MAP
	    INTEGER*4 L_KERNEL
	  END MAP
	  MAP
	    INTEGER*4 L_MSGDSP
	  END MAP
	END UNION
	INTEGER*4 L_EXEC
	INTEGER*4 L_USRUNDWN
	INTEGER*4 %FILL
	INTEGER*4 L_RMS
	INTEGER*4 L_CHECK
      END STRUCTURE
      RECORD /PLV/ PLV
C
C*********************************************************************
C
C  begin the code:
C
C  get random statistical stuff
C
      CALL SYS$ASCTIM(,DT_STR,,)
      ICODE=LIB$INIT_TIMER()
      IF(.NOT.ICODE)CALL LIB$SIGNAL(%VAL(ICODE))
C
C  get the input command line
C
      ICODE=LIB$GET_FOREIGN(CMD_LIN,'$_File_:	',LN)
      IF(ICODE.EQ.%LOC(RMS$_EOF))THEN
	CALL EXIT
      ELSEIF(.NOT.ICODE)THEN
	CALL LIB$SIGNAL(%VAL(ICODE))
      ENDIF
C
C  analyze the command line
C
      OUT_FIL=' '
C
C  open the input file
C
      OPEN(UNIT=1,FILE=CMD_LIN(1:LN),ACCESS='DIRECT',READONLY,
     +	   FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL',BUFFERCOUNT=16,
     +	   RECL=128,RECORDTYPE='FIXED',STATUS='OLD',DEFAULTFILE='.EXE')
C
C  read in the image header record from the input file
C
      READ(1,REC=1) (HDR_BUF(I),I=0,511)
C
C  abort if not a native-mode image
C
      IF(HDR_BUF(511).EQ.0.AND.HDR_BUF(510).EQ.0)THEN
	CALL SYS$EXIT(DISM__COMPATIMG)
      ELSEIF(HDR_BUF(511).EQ.'FF'X.AND.HDR_BUF(510).EQ.'FF'X)THEN
	CONTINUE		! normal image
      ELSEIF(HDR_BUF(511).EQ.0.AND.HDR_BUF(510).GE.1.AND.
     +				   HDR_BUF(510).LE.3)THEN
	CALL LIB$SIGNAL(DISM__NONSTDIMG,%VAL(1),IMG_LNK_TYP(HDR_BUF(510)))
      ELSE
	CALL LIB$SIGNAL(DISM__NOIMGHDR)
	CMD_LIN=' '
	CALL LIB$GET_INPUT(CMD_LIN,'Is this a system image (Y/N) ? ')
	IF(CMD_LIN(1:1).EQ.'Y'.OR.CMD_LIN(1:1).EQ.'y')THEN
	  CALL LIB$GET_INPUT(CMD_LIN,'Base address of image (hex) > ',LN)
	  READ(CMD_LIN(1:LN),'(Z)') ISD_BASEVA(1)
	  ISD_NUM=1
	  ISD(1).W_SIZE=16
	  J=1
	  ICODE=0
	  DO WHILE (ICODE.EQ.0)
	    J=J+1
	    READ(1,REC=J,IOSTAT=ICODE)
	  ENDDO
	  ISD(1).W_PAGCNT=J-1
	  ISD(1).L_VPNPFC=JISHFT(ISD_BASEVA(1),-9)
	  ISD(1).L_FLAGS='38A'X	! ISD$M_BASED, ISD$M_COPYALWAYS,
				! ISD$M_LASTCLUSTER, ISD$M_WRT, ISD$M_CRF
	  ISD(1).L_VBN=1
	  ISD(1).L_IDENT=0
	  ISD(1).B_GBLNAMLEN=0
	  ISD(1).T_GBLNAM=' '
	  ISD_PGEND(1)=ISD_BASEVA(1)-1+512*JZEXT(ISD(1).W_PAGCNT)
	  ISD_NAM(1)=' '
	  ISD_LAST_P0PAGE=ISD_PGEND(1)
	  IHD.W_SIZE=0
	  IHD.W_ACTIVOFF=0
	  IHD.W_SYMDBGOFF=0
	  IHD.W_IMGIDOFF=0
	  IHD.W_PATCHOFF=0
	  IHD.W_MAJORID=0
	  IHD.W_MINORID=0
	  IHD.B_HDRBLKCNT=0
	  IHD.B_IMGTYPE=1
	  IHD.Q_PRIVREQS(1)=0
	  IHD.Q_PRIVREQS(2)=0
	  IHD.W_IOCHANCNT=0
	  IHD.W_IMGIOCNT=0
	  IHD.L_LNKFLAGS='32'X	! LNK$M_DBGDMT, LNK$M_P0IMAGE, LNK$M_LNKNOTFR
	  IHD.L_IDENT=0
	  IHD.L_SYSVER=0
	  IHD.L_IAFVA=0
	  INQUIRE(UNIT=1,NAME=OUT_FIL)
	  CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
	  I=INDEX(OUT_FIL(1:LN),']')
	  I=I+1
	  J=INDEX(OUT_FIL(I:LN),'.')+I-2
	  IHI.T_IMGNAM=OUT_FIL(I:J)
	  OUT_FIL=' '
	  IHI.B_IMGNAMLEN=J-I+1
	  IHI.T_IMGID='?SYSTEM?'
	  IHI.B_IMGIDLEN=8
	  IHI.T_LINKID='??.??'
	  IHI.B_LINKIDLEN=5
	  GOTO 10	! skip normal image header crunching
	ELSE
	  CALL SYS$EXIT(SS$_BADIMGHDR)
	ENDIF
      ENDIF
C
C  copy image header's header from buffer to structure
C
      CALL LIB$MOVC3(IHD$S_SIZE,HDR_BUF(0),IHD)
C
C  copy any additional blocks of header to header buffer
C
      DO I=1,IHD.B_HDRBLKCNT-1
	READ(1,REC=I+1) (HDR_BUF(I*512+J),J=0,511)
      ENDDO
C
C  copy image activation address vector from buffer to structure
C
      CALL LIB$MOVC3(IHA$S_SIZE,HDR_BUF(IHD.W_ACTIVOFF),IHA)
C
C  copy image header symbol table pointers from buffer to structure
C
      CALL LIB$MOVC3(IHS$S_SIZE,HDR_BUF(IHD.W_SYMDBGOFF),IHS)
C
C  copy identification section from buffer to structure
C
      CALL LIB$MOVC3(IHI$S_SIZE,HDR_BUF(IHD.W_IMGIDOFF),IHI)
C
C  if patch offset specified then copy patch data from buffer to structure
C
      IF(IHD.W_PATCHOFF.NE.0)THEN
	CALL LIB$MOVC3(IHP$S_SIZE,HDR_BUF(IHD.W_PATCHOFF),IHP)
      ENDIF
C
C  begin transferring image section descriptors to arrays
C
      I=IHD.W_SIZE	! get beginning of ISD list
      ISD_PRESENT=.TRUE.
      ISD_NUM=0
      ISD_LAST_P0PAGE=-1
      DO WHILE (ISD_PRESENT)
	ISD_NUM=ISD_NUM+1
	IF(ISD_NUM.GT.ISD_TBL_SIZE)THEN
	  CALL LIB$SIGNAL(DISM__ISDTBLOVF)
	ENDIF
	CALL LIB$MOVC3(ISD$S_SIZE,HDR_BUF(I),ISD(ISD_NUM))
	IF(ISD(ISD_NUM).W_SIZE .EQ. 0)THEN
	  ISD_NUM=ISD_NUM-1
	  ISD_PRESENT=.FALSE.
	ELSEIF(ISD(ISD_NUM).W_SIZE .EQ. 'FFFF'X)THEN	! end of block wrap-around
	  I=IAND(I+511,.NOT.'1FF'X)	! advance to beginning of next block
	  ISD_NUM=ISD_NUM-1	! back up ISD counter
	ELSE	! this is where all work actually gets done in this loop
	  ISD_NAM(ISD_NUM)=' '
	  ISD_BASEVA(ISD_NUM)=512*(ISD(ISD_NUM).L_VPNPFC .AND. '007FFFFF'X)
	  ISD_PGEND(ISD_NUM)=ISD_BASEVA(ISD_NUM)-1+
     +					512*JZEXT(ISD(ISD_NUM).W_PAGCNT)
	  IF(JISHFT(ISD(ISD_NUM).L_FLAGS ,-24).NE.-3.AND.
     +	     JISHFT(ISD(ISD_NUM).L_FLAGS ,-24).NE.253)THEN
	    ISD_LAST_P0PAGE=ISD_PGEND(ISD_NUM)
	  ENDIF
	  IF(ISD(ISD_NUM).W_SIZE .LE.16)THEN
	    ISD(ISD_NUM).L_IDENT=0
	    ISD(ISD_NUM).B_GBLNAMLEN=0
	    ISD(ISD_NUM).T_GBLNAM=' '
	    IF(ISD(ISD_NUM).W_SIZE .LE.12)THEN
	      ISD(ISD_NUM).L_VBN=0
	    ENDIF
	  ENDIF
	  I=I+ISD(ISD_NUM).W_SIZE
	ENDIF
      ENDDO
C
C  calculate approximate allocation size for output file
C
   10 I2=2+ISD_NUM	! allow space for image header and I-sect text
      DO I=1,ISD_NUM
	IF(JISHFT(ISD(I).L_FLAGS ,-24).EQ.-3.OR.
     +	   JISHFT(ISD(I).L_FLAGS ,-24).EQ.253.OR.	! skip stack
     +	   (ISD(I).L_FLAGS .AND.1).NE.0)THEN	! skip referenced shrimg's
	  CONTINUE
	ELSEIF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)THEN	! add vector sections
	  I2=I2+2*ISD(I).W_PAGCNT
	ELSEIF((ISD(I).L_FLAGS .AND.4).NE.0)THEN	! add demand-zero sections
	  I2=I2+ISD(I).W_PAGCNT/2
	ELSE					! add other types of sections
	  I2=I2+5*ISD(I).W_PAGCNT
	ENDIF
      ENDDO
C
C  generate name for output file
C
      IF(OUT_FIL(1:1).EQ.' ')THEN
	INQUIRE(UNIT=1,NAME=OUT_FIL)
	CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
	I=INDEX(OUT_FIL(1:LN),']')
	I=I+1
	J=INDEX(OUT_FIL(I:LN),'.')+I-2
      ELSE
	I=1
	CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
	J=LN
      ENDIF
C
C  open output file
C
      OPEN(UNIT=2,FILE=OUT_FIL(I:J),STATUS='NEW',
     +	   FORM='FORMATTED',CARRIAGECONTROL='LIST',
     +	   DEFAULTFILE='.MAR',INITIALSIZE=I2,
     +	   BLOCKSIZE=MIN(I2*512,16384))
C
C  print initial information to the output file
C
      IF(OUT_FIL(I:J) .NE. IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN))THEN
	CALL LIB$SIGNAL(DISM__DIFINTNAM,%VAL(2),OUT_FIL(I:J),
     +				IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN))
      ENDIF
      INQUIRE(UNIT=1,NAME=CMD_LIN)
      CALL STR$TRIM(CMD_LIN,CMD_LIN,LN)
 9000 FORMAT(A1,'.TITLE',A1,A,' ',A,' Disassembly')
 9001 FORMAT(A1,'.IDENT',A1,'/',A,'/')
 9002 FORMAT(';')
 9003 FORMAT(';  Disassembly of ',A/
     +	';',A1,'on ',A,' by VAX/VMS DISM32 V4.0')
 9004 FORMAT(';  as linked by LINK-32 V',A,' on ',A23)
      IF((IHD.L_LNKFLAGS .AND.'20'X).EQ.0)THEN	! VMS V3- version of linker
        WRITE(2,9000) TAB, TAB, IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN),
     +			CMD_LIN(1:LN)
        WRITE(2,9001) TAB, TAB, IHI.T_IMGID_V3(1:IHI.B_IMGIDLEN_V3)
        WRITE(2,9002)
        WRITE(2,9003) CMD_LIN(1:LN), TAB, DT_STR
        WRITE(2,9002)
        CALL SYS$ASCTIM(,S_TMP,IHI.Q_LINKTIME_V3,)
        WRITE(2,9004) IHI.T_LINKID_V3(1:IHI.B_LINKIDLEN_V3), S_TMP(1:23)
      ELSE	! VMS V4+ version of link
        WRITE(2,9000) TAB, TAB, IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN),
     +			CMD_LIN(1:LN)
        WRITE(2,9001) TAB, TAB, IHI.T_IMGID(1:IHI.B_IMGIDLEN)
        WRITE(2,9002)
        WRITE(2,9003) CMD_LIN(1:LN), TAB, DT_STR
        WRITE(2,9002)
        CALL SYS$ASCTIM(,S_TMP,IHI.Q_LINKTIME,)
        WRITE(2,9004) IHI.T_LINKID(1:IHI.B_LINKIDLEN), S_TMP(1:23)
      ENDIF
      WRITE(2,9002)
      IF(IHD.B_IMGTYPE.EQ.1)THEN
	S_TMP='executable (IHD$K_EXE)'
      ELSEIF(IHD.B_IMGTYPE.EQ.2)THEN
	S_TMP='shareable (IHD$K_LIM)'
      ELSE
	CLOSE(UNIT=1)
	CLOSE(UNIT=2,DISP='DELETE')
	CALL SYS$EXIT(DISM__UNKIMGTYP)
      ENDIF
      IF((IHD.L_LNKFLAGS .AND.'20'X).EQ.0)THEN	! VMS V3- version of linker
	WRITE(2,9005) IHI.T_IMGID_V3(1:IHI.B_IMGIDLEN_V3), S_TMP(1:22),
     +			ISD_NUM, IHD.B_HDRBLKCNT, IHS.W_DSTBLKS, IHS.W_GSTRECS
      ELSE	! VMS V4+ version of link
	WRITE(2,9005) IHI.T_IMGID(1:IHI.B_IMGIDLEN), S_TMP(1:22),
     +			ISD_NUM, IHD.B_HDRBLKCNT, IHS.W_DSTBLKS, IHS.W_GSTRECS
      ENDIF
 9005 FORMAT(';  image ID = ',A,', type ',A/
     +	';  contains ',I5,' image sections'/
     +	';'/
     +	';  header contains',I2,' blocks'/
     +	';  image contains ',I5,' blocks of debug symbol table data,'/
     +	';    and ',I5,' records of global symbol table data')
      IF(IHD.B_IMGTYPE .EQ.2)THEN
	LN=ISHFT(IHD.L_LNKFLAGS,-24).AND.'FF'X
	WRITE(2,9022) ISHFT(IHD.L_IDENT,-24), IAND(IHD.L_IDENT,'FFFFFF'X),
     +			C_MATCH_TYPE(LN)
 9022	FORMAT(';'/
     +	';  global section major ID: %X''',Z2.2,
     +			''', minor ID: %X''',Z6.6,''''/
     +	';      match control: ISD$K_',A)
      ENDIF
      LN=1
      S_TMP=' '
      IF((IHD.L_LNKFLAGS.AND.1).NE.0)THEN
	S_TMP='LNKDEBUG'
	LN=9
      ENDIF
      IF((IHD.L_LNKFLAGS.AND.2).NE.0)THEN
	S_TMP(LN+1:)='LNKNOTFR'
	LN=LN+10
      ENDIF
      IF((IHD.L_LNKFLAGS.AND.4).NE.0)THEN
	S_TMP(LN+1:)='NOP0BUFS'
	LN=LN+10
      ENDIF
      IF((IHD.L_LNKFLAGS.AND.8).NE.0)THEN
	S_TMP(LN+1:)='PICIMG'
	LN=LN+8
      ENDIF
      IF((IHD.L_LNKFLAGS.AND.'10'X).NE.0)THEN
	S_TMP(LN+1:)='P0IMAGE'
	LN=LN+9
      ENDIF
      IF((IHD.L_LNKFLAGS.AND.'20'X).NE.0)THEN
	S_TMP(LN+1:)='DBGDMT (V4+)'
	LN=LN+14
      ENDIF
      IF((IHD.L_LNKFLAGS.AND.'40'X).NE.0)THEN
	S_TMP(LN+1:)='INISHR'
	LN=LN+8
      ENDIF
      WRITE(2,9017) S_TMP(1:LN), IHD.W_IOCHANCNT, IHD.W_IMGIOCNT
 9017 FORMAT(';  linker flags: ',A/
     +	     ';  I/O channel count =',I4,', image I/O count =',I4)
      IF(IHD.L_SYSVER .NE.0)THEN
	WRITE(2,9021) IHD.L_SYSVER
 9021	FORMAT(';  system version: ',A4)
      ENDIF
      WRITE(2,9006) IHD.Q_PRIVREQS(2), IHD.Q_PRIVREQS(1)
 9006 FORMAT(';  requested privilege mask = ',Z8,' ',Z8)
      WRITE(2,9002)
      S_TMP=';  uses shareable images'
      LN=24
      DO I=1,ISD_NUM
	IF((ISD(I).L_FLAGS .AND.1).NE.0)THEN	! ISD$M_GBL
	  LN2=ISD(I).B_GBLNAMLEN
	  IF(ISD(I).T_GBLNAM(LN2-3:LN2).EQ.'_001')THEN
	    LN2=LN2-4
	  ENDIF
	  IF(ISD(I).T_GBLNAM(LN2-3:LN2-1).NE.'_00')THEN
	    S_TMP(LN+1:)='  '//ISD(I).T_GBLNAM(1:LN2)
	    LN=LN+LN2+2
	  ENDIF
	ENDIF
      ENDDO
      IF(LN.GT.24)THEN
	WRITE(2,'(A)') S_TMP(1:LN)
      ENDIF
      IF(IHD.W_PATCHOFF.EQ.0)THEN
	WRITE(2,9007)
 9007	FORMAT(';  no patches made to this image')
      ELSE
	S_TMP=';  image has been patched to ECO levels '
	LN=40
	DO I=0,127
	  ICODE=LIB$FFS(I,1,IHP.L_ECO1,J)	! test next bit in ECO mask
	  IF(ICODE)THEN
	    CALL SYS$FAO('!UL,',LN2,S_TMP(LN+1:),%VAL(I+1))
	    LN=LN+LN2
	    IF(LN.GT.72)THEN
	      WRITE(2,'(A)') S_TMP(1:LN)
	      S_TMP=';'
	      LN=40
	    ENDIF
	  ENDIF
	ENDDO
	IF(LN.GT.41)THEN
	  LN=LN-1
	  WRITE(2,'(A)') S_TMP(1:LN)
	ENDIF
	CALL SYS$ASCTIM(,S_TMP,IHP.Q_PATDATE,)
	WRITE(2,9009)S_TMP(1:23)
 9009	FORMAT(';  date of last patch is ',A23)
	WRITE(2,9016) IHP.L_RW_PATSIZ, IHP.L_RW_PATADR,
     +			IHP.L_RO_PATSIZ, IHP.L_PATADR
 9016	FORMAT(';  read/write patch area has length',I5,', address',Z9.8/
     +	       ';  read-only patch area has length',I5,', address',Z9.8)
	WRITE(2,9010)
 9010	FORMAT(';  PATCH journal text for patches starts next page:')
	WRITE(2,9002)
	WRITE(2,9012)form_feed,TAB,TAB
 9012	FORMAT(A1/
     +	       A1,'.SBTTL',A1,'Image Patch Journals')
	WRITE(2,9002)
	WRITE(2,9013)
 9013	FORMAT(';  PATCH journal text:')
	WRITE(2,9002)
	CALL LIB$ESTABLISH(FIX_BUF_1)
	I=0
	CUR_VBN=IHP.L_PATCOMTXT
	OK=.TRUE.
	READ(1,REC=CUR_VBN) REC_BUF
	DO WHILE (OK)
	  CALL COPY_WORD(I,K)		! get length of text
	  I=I+2
	  IF(K.NE.0.AND.(CUR_VBN+1.LT.INP_FIL_SIZ.OR.K+I.LT.512))THEN
	    DO J=1,K
	      CALL COPY_BYTE(I,I2)	! read in line
	      S_TMP(J:J)=CHAR(I2)
	      I=I+1
	    ENDDO
	    WRITE(2,9015)TAB,S_TMP(1:K)
 9015	    FORMAT(';',A1,A)
	    IF(MOD(I,2).NE.0)I=I+1
	  ELSE
	    OK=.FALSE.
	  ENDIF
	ENDDO
	CALL LIB$REVERT
      ENDIF
C
C  put initial entry(s) into symbol table
C
      SYM_TBL_PTR=0
      MOD_TBL_PTR=0
      OLD_MODTB_PTR=0
      LIN_TBL_PTR=0
      OLD_LINTB_PTR=1
      J=0
      DO I=1,3
	IF(IHA.L_TFRADR(I).NE.0)THEN
	  SYM_TBL_PTR=SYM_TBL_PTR+1
	  SYM_VAL(SYM_TBL_PTR)=IHA.L_TFRADR(I)
	  SYM_TYP(SYM_TBL_PTR)=SYM_PROC
	  IF(IHA.L_TFRADR(I).GE.0)THEN
	    J=J+1
	    IF((IHD.L_LNKFLAGS.AND.2).EQ.0)THEN
	      S_TMP='$MAIN'
	      LN=5
	    ELSE
	      S_TMP='$ENTRY'
	      LN=6
	    ENDIF
	    IF(J.NE.1)THEN
	      S_TMP(LN+1:)='_'//CHAR(J+ICHAR('0'))
	      LN=LN+2
	    ENDIF
	    IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN	! VMS V3- linker
	      SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN)
     +				//S_TMP(1:LN)
	    ELSE	! VMS V4+ linker
	      SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)//
     +				S_TMP(1:LN)
	    ENDIF
	  ENDIF
	ENDIF
      ENDDO
C
C   IF no transfer addresses found THEN
C
      IF(SYM_TBL_PTR.EQ.0)THEN
C
C     test if we have a device driver image
C
	IF(ISD(1).L_VBN .NE.0)THEN
	  READ(1,REC=ISD(1).L_VBN) REC_BUF
	  IF(REC_BUF(10).EQ.%LOC(DYN$C_DPT))THEN
	    CALL LIB$PUT_OUTPUT('Assuming a device driver image...')
	    CALL LIB$MOVC3(DPT$S_SIZE,REC_BUF(0),DPT)
	    WRITE(2,9020) form_feed, TAB, TAB, TAB, TAB, TAB, TAB, TAB,
     +			  TAB, TAB, TAB, TAB, TAB, TAB, TAB
 9020	    FORMAT(A1/
     +		   A1,'.SBTTL',A1,'External symbol definitions'/
     +		   ';'/
     +		   ';  External symbols'/
     +		   ';'/
     +		   A1,'.LIBRARY',A1,'/SYS$LIBRARY:LIB/'/
     +		   A1,'$CRBDEF ; Channel request block'/
     +		   A1,'$DCDEF  ; Device classes and types'/
     +		   A1,'$DDBDEF ; Device data block'/
     +		   A1,'$DYNDEF ; Dynamic-data-structure types'/
     +		   A1,'$IDBDEF ; Interrupt data block'/
     +		   A1,'$IRPDEF ; I/O request packet'/
     +		   A1,'$IODEF  ; I/O function codes'/
     +		   A1,'$SSDEF  ; system condition codes'/
     +		   A1,'$UCBDEF ; Unit control block'/
     +		   A1,'$VECDEF ; Interrupt vector block')
	    SYM_VAL(1)=0	! end of device driver
	    SYM_TYP(1)=SYM_D_DPT+SYM_NOTDEF
	    SYM_NAM(1)='DPT$TAB'
	    SYM_VAL(2)=DPT.W_SIZE	! end of device driver
	    SYM_TYP(2)=SYM_D_QUD
	    SYM_NAM(2)=DPT.T_NAME(1:2)//'$END_OF_DRIVER'
	    SYM_VAL(3)=DPT.W_INITTAB	! initialization table
	    SYM_TYP(3)=SYM_D_INITAB+SYM_NOTDEF
	    SYM_NAM(3)='DPT$INITAB'
	    SYM_VAL(4)=DPT.W_REINITTAB	! reinitialization table
	    SYM_TYP(4)=SYM_D_REINITAB+SYM_NOTDEF
	    SYM_NAM(4)='DPT$REINITAB'
	    SYM_TBL_PTR=4
	    IF(DPT.W_UNLOAD .NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(4)=DPT.W_UNLOAD	! unload routine
	      SYM_TYP(4)=SYM_SUBR
	      SYM_NAM(4)=DPT.T_NAME(1:2)//'$UNLOAD'
	    ENDIF
	    IF(DPT.W_DELIVER .NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=DPT.W_DELIVER	! deliver routine
	      SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
	      SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$DELIVER'
	    ENDIF
	    IF(DPT.W_VECTOR .NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=DPT.W_VECTOR	! driver vector
	      SYM_TYP(SYM_TBL_PTR)=SYM_D_LNG
	      SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$VECTOR'
	    ENDIF
	    ADDR=DPT.W_INITTAB
	    CALL LIB$MOVC3(DPT_STORE$S_SIZE,REC_BUF(ADDR),DPT_STORE)
	    DO WHILE (DPT_STORE.B_STRUCTYPE .NE.0)
	      IF(DPT_STORE.B_OPERATION .EQ.0)THEN	! B
		ADDR=ADDR+4
	      ELSEIF(DPT_STORE.B_OPERATION .EQ.1.OR.
     +		     DPT_STORE.B_OPERATION .EQ.2)THEN	! W, D
		ADDR=ADDR+5
	      ELSEIF((DPT_STORE.B_OPERATION .AND.'7F'X).EQ.4)THEN ! V
		ADDR=ADDR+9
	      ELSEIF(DPT_STORE.B_OPERATION .EQ.3.OR.
     +		     (DPT_STORE.B_OPERATION .AND.'80'X).NE.0)THEN ! L, @
		ADDR=ADDR+7
	      ELSE
		CALL LIB$SIGNAL(DISM__INVINITAB,%VAL(2),%VAL(ADDR),
     +				%VAL(DPT_STORE.B_OPERATION))
	      ENDIF
	      IF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_DDB).AND.
     +		 DPT_STORE.B_STRUCOFFSET .EQ.12.AND.
     +		 DPT_STORE.B_OPERATION .EQ.2)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL	! DDT address
		SYM_TYP(SYM_TBL_PTR)=SYM_D_DDT+SYM_NOTDEF
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$DDT'
		CALL LIB$MOVC3(DDT$S_SIZE,REC_BUF(DPT_STORE.W_WORDVAL),DDT)
		DDT_ADR=DPT_STORE.W_WORDVAL
	      ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND.
     +		     DPT_STORE.B_STRUCOFFSET .EQ.'28'X.AND.
     +		     DPT_STORE.B_OPERATION .EQ.2)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL	! int svc address
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$INTR_SVC'
	      ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND.
     +		     DPT_STORE.B_STRUCOFFSET .EQ.'30'X.AND.
     +		     DPT_STORE.B_OPERATION .EQ.2)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL	! ctrlinit address
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$CTRLINIT'
	      ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND.
     +		     DPT_STORE.B_STRUCOFFSET .EQ.'3C'X.AND.
     +		     DPT_STORE.B_OPERATION .EQ.2)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL	! unitinit address
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$UNITINIT'
	      ELSEIF(DPT_STORE.B_STRUCTYPE .EQ.%LOC(DYN$C_CRB).AND.
     +		     DPT_STORE.B_STRUCOFFSET .EQ.'4C'X.AND.
     +		     DPT_STORE.B_OPERATION .EQ.2)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DPT_STORE.W_WORDVAL	! int svc #2 address
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$INTR_SVC_2'
	      ELSEIF(DPT_STORE.B_OPERATION .EQ.2)THEN
		CALL WRITE_SYM_TBL(%VAL(DPT_STORE.W_WORDVAL),%VAL(SYM_SUBR),,)
	      ELSEIF((DPT_STORE.B_OPERATION .AND.'80'X).NE.0)THEN
		I3=(DPT_STORE.B_OPERATION .AND.'7F'X)
		IF(I3.EQ.3)I3=2
		IF(I3.LE.3)THEN
		  CALL WRITE_SYM_TBL(%VAL(DPT_STORE.L_LONGVAL),
     +				     %VAL(JISHFT(1,3+I3)),,)	! SYM_D_BYT+
		ENDIF
	      ENDIF
	      CALL LIB$MOVC3(DPT_STORE$S_SIZE,REC_BUF(ADDR),DPT_STORE)
	    ENDDO
	    IF(DDT_ADR.NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=DDT.L_START+DDT_ADR	! start I/O routine
	      SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
	      SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$START'
	      IF(DDT.L_UNSOLINT .GT.0)THEN
		SYM_VAL(SYM_TBL_PTR)=DDT.L_UNSOLINT+DDT_ADR	! unsolicited int svc
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$UNSOLINT'
		SYM_TBL_PTR=SYM_TBL_PTR+1
	      ENDIF
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=DDT.L_FDT+DDT_ADR	! FDT table
	      SYM_TYP(SYM_TBL_PTR)=SYM_D_FDT
	      SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$FDT'
	      IF(DDT.L_CANCEL .GT.0)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DDT.L_CANCEL+DDT_ADR	! cancel I/O routine
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$CANCEL'
	      ENDIF
	      IF(DDT.L_REGDUMP .GT.0)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DDT.L_REGDUMP+DDT_ADR	! register dump routine
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$REGDUMP'
	      ENDIF
	      IF(DDT.L_UNITINIT .GT.0)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DDT.L_UNITINIT+DDT_ADR	! unit init routine
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$UNITINIT'
	      ENDIF
	      IF(DDT.L_ALTSTART .GT.0)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DDT.L_ALTSTART+DDT_ADR	! alt start I/O routine
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$ALTSTART'
	      ENDIF
	      IF(DDT.L_CLONEDUCB .GT.0)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		SYM_VAL(SYM_TBL_PTR)=DDT.L_CLONEDUCB+DDT_ADR	! cloned UCB routine
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$CLONEDUCB'
	      ENDIF
	      IF(DDT.L_FDT .GE.48)THEN
		IF(DDT.L_MNTV_SSSC .GT.0)THEN
		  SYM_TBL_PTR=SYM_TBL_PTR+1
		  SYM_VAL(SYM_TBL_PTR)=DDT.L_MNTV_SSSC+DDT_ADR	! mntver SSSC
		  SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		  SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$MNTV_SSSC'
		ENDIF
	      ENDIF
	      IF(DDT.L_FDT .GE.52)THEN
		IF(DDT.L_MNTV_FOR .GT.0)THEN
		  SYM_TBL_PTR=SYM_TBL_PTR+1
		  SYM_VAL(SYM_TBL_PTR)=DDT.L_MNTV_FOR+DDT_ADR	! mntver foreign
		  SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		  SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$MNTV_FOR'
		ENDIF
	      ENDIF
	      IF(DDT.L_FDT .GE.56)THEN
		IF(DDT.L_MNTV_SQD .GT.0)THEN
		  SYM_TBL_PTR=SYM_TBL_PTR+1
		  SYM_VAL(SYM_TBL_PTR)=DDT.L_MNTV_SQD+DDT_ADR	! mntver sequential
		  SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		  SYM_NAM(SYM_TBL_PTR)=DPT.T_NAME(1:2)//'$MNTV_SQD'
		ENDIF
	      ENDIF
	      I2=DDT.W_FDTSIZE-16
	      I9=0
	      ADDR=DDT.L_FDT+DDT_ADR+16
	      CALL LIB$ESTABLISH(FIX_BUFR_OVRFL)
	      CUR_VBN=ISD(1).L_VBN+INT((ADDR-ISD_BASEVA(1))/512)
	      CUR_VA=(ADDR.AND..NOT.'1FF'X)
	      READ(1,REC=CUR_VBN) REC_BUF
	      DO WHILE (I2.GT.0)
		CALL COPY_LONG(ADDR,I_FLT(1))
		ADDR=ADDR+4
		CALL COPY_LONG(ADDR,I_FLT(2))
		ADDR=ADDR+4
		CALL COPY_LONG(ADDR,I3)
		ADDR=ADDR+4
		I9=I9+1
		I2=I2-12
		SYM_TBL_PTR=SYM_TBL_PTR+1
		IF(I3.GT.0)THEN
		  SYM_VAL(SYM_TBL_PTR)=I3+ADDR-12	! relative to base of block
		ELSE
		  SYM_VAL(SYM_TBL_PTR)=I3
		ENDIF
		SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
		CALL BUILD_IO_LIST(I_FLT,S_TMP,LN,LN2)
		I3=INDEX(S_TMP(1:LN),',')
		IF(I3.EQ.0)I3=LN
		IF(LN2.EQ.1)THEN
		  CALL SYS$FAO('!AS$FDT_!AS',LN,SYM_NAM(SYM_TBL_PTR),
     +				DPT.T_NAME(1:2),S_TMP(2:I3-1))
		ELSE
		  CALL SYS$FAO('!AS$FDT_!AS_!UW',LN,SYM_NAM(SYM_TBL_PTR),
     +				DPT.T_NAME(1:2),S_TMP(2:I3-1),%VAL(LN2))
		ENDIF
		SYM_NAM(SYM_TBL_PTR)(LN+1:)=' '
	      ENDDO
	    ENDIF
	  ENDIF
	ENDIF
C
      ENDIF
C
C  scan for and process any change-mode vector sections in image
C
      DO I=1,ISD_NUM
	IF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)THEN	! ISD$M_VECTOR
	  READ(1,REC=ISD(I).L_VBN) REC_BUF
	  CALL LIB$MOVC3(32,REC_BUF(0),PLV)
	  IF(PLV.L_TYPE .EQ.1)THEN	! PLV$C_TYP_CMOD
	    IF(PLV.L_KERNEL .NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=PLV.L_KERNEL+8+ISD_BASEVA(I)
	      SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
	      IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN	! VMS V3- linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN)
     +				//'$CHMK_DISPATCHER'
	      ELSE	! VMS V4+ linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)//
     +				'$CHMK_DISPATCHER'
	      ENDIF
	    ENDIF
	    IF(PLV.L_EXEC .NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=PLV.L_EXEC+12+ISD_BASEVA(I)
	      SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
	      IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN	! VMS V3- linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN)
     +				//'$CHME_DISPATCHER'
	      ELSE	! VMS V4+ linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)//
     +				'$CHME_DISPATCHER'
	      ENDIF
	    ENDIF
	    IF(PLV.L_USRUNDWN .NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=PLV.L_USRUNDWN+16+ISD_BASEVA(I)
	      SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
	      IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN	! VMS V3- linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN)
     +				//'$USER_RUNDOWN'
	      ELSE	! VMS V4+ linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)//
     +				'$USER_RUNDOWN'
	      ENDIF
	    ENDIF
	    IF(PLV.L_RMS .NE.0)THEN
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(SYM_TBL_PTR)=PLV.L_RMS+24+ISD_BASEVA(I)
	      SYM_TYP(SYM_TBL_PTR)=SYM_SUBR
	      IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN	! VMS V3- linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM_V3(1:IHI.B_IMGNAMLEN)
     +				//'$RMS_DISPATCHER'
	      ELSE	! VMS V4+ linker
		SYM_NAM(SYM_TBL_PTR)=IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)//
     +				'$RMS_DISPATCHER'
	      ENDIF
	    ENDIF
	  ENDIF
	ENDIF
      ENDDO
C
C  if file filename.SYM exists, open it as a file and read it for
C    user symbol declarations
C
C	Format of user declarations:
C	if it works,
C		columns 1-8	Z8 value of symbol
C			10-17	Z8 type code
C			19-22	I4 extended type
C			24-31	Z8 extended value
C			33-63	A31 name of symbol
C	else just use (old format)
C		columns 1-8	Z8 value of symbol
C			10-17	Z8 type code
C			19-49	A31 name of symbol
C	end-of-file marks end of list
C
	INQUIRE(UNIT=1,NAME=OUT_FIL)
	CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
	I=INDEX(OUT_FIL(1:LN),']')
	I=I+1
	J=INDEX(OUT_FIL(I:LN),'.')+I-2
	OPEN(UNIT=3,FILE=OUT_FIL(I:J),READONLY,
     +	     FORM='FORMATTED',RECORDTYPE='VARIABLE',STATUS='OLD',
     +	     IOSTAT=ICODE,DEFAULTFILE='.SYM',SHARED,ACCESS='SEQUENTIAL')
	IF(ICODE.EQ.0)THEN
	  OK=.TRUE.
	  DO WHILE (OK)
	    READ(3,'(Q,A)',END=1940) LN2,S_TMP
	    READ(S_TMP(1:LN2),9190,ERR=1930)I,I2,LN,I9,ROUTINE_NAME
 9190	    FORMAT(BZ,2(Z8,X),I4,X,Z8,X,A)
	    GOTO 1931
 1930	    READ(S_TMP(1:LN2),9191)I,I2,ROUTINE_NAME
 9191	    FORMAT(BZ,2(Z8,X),A)
	    LN=0
	    I9=0
 1931	    IF((I2.AND.SYM_NOTDEF).NE.0.AND.
     +	       (I2.AND.SYM_D_EXTENDED).EQ.0) ROUTINE_NAME=' '
	    DO J=1,SYM_TBL_PTR
	      IF(SYM_VAL(J).EQ.I)THEN
		SYM_NAM(J)=ROUTINE_NAME
		SYM_TYP(J)=SYM_TYP(J).OR.I2
		IF((I2.AND.SYM_D_EXTENDED).NE.0.AND.
     +		   LN.GT.SYM_EXT_ATTR(J))THEN
		  SYM_EXT_ATTR(J)=LN
		  SYM_EXT_VAL(J)=I9
		ENDIF
		GOTO 1950
	      ENDIF
	    ENDDO
	    SYM_TBL_PTR=SYM_TBL_PTR+1
	    IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN
	      CALL LIB$SIGNAL(DISM__SYMTBLOVF)
	    ELSE
	      SYM_VAL(SYM_TBL_PTR)=I
	      SYM_TYP(SYM_TBL_PTR)=I2
	      SYM_NAM(SYM_TBL_PTR)=ROUTINE_NAME
	      SYM_EXT_ATTR(SYM_TBL_PTR)=LN
	      SYM_EXT_VAL(SYM_TBL_PTR)=I9
	    ENDIF
	    GOTO 1950
 1940	    OK=.FALSE.
 1950	    CONTINUE
	  ENDDO
	  CLOSE(UNIT=3)
	ELSEIF(ICODE.NE.29)THEN	! it's OK if file not found error occurs
	  CALL LIB$SIGNAL(DISM__BADUSRSFL,%VAL(2),%VAL(ICODE),
     +		%DESCR(IHI.T_IMGNAM(1:IHI.B_IMGNAMLEN)//'.SYM'))
	ENDIF
C
C  read in global symbol table records (if any), and assign names to
C    corresponding entries in symbol table
C
      CALL LIB$ESTABLISH(FIX_BUF_1)
      IF(IHS.W_GSTRECS .GT.0)THEN
	CUR_VBN=IHS.L_GSTVBN
	CUR_VA=0
	READ(1,REC=CUR_VBN) REC_BUF	! get 1st block of global symbol table
	INQUIRE(UNIT=1,NAME=OUT_FIL)
	CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
	I=INDEX(OUT_FIL(1:LN),']')
	I=I+1
	J=INDEX(OUT_FIL(I:LN),'.')+I-2
	OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW',
     +	     FORM='UNFORMATTED',DEFAULTFILE='.GST',RECORDTYPE='VARIABLE')
	CALL NAME_SYM_TBL(-JZEXT(IHS.W_GSTRECS),0,0)	! fill in names into symbol, ISD tables
	CLOSE(UNIT=99)
      ENDIF
C
C  read debug symbol table blocks (if any), and assign names to
C    corresponding entries in symbol table
C
      IF(IHS.W_DSTBLKS .GT.0)THEN
	INQUIRE(UNIT=1,NAME=OUT_FIL)
	CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
	I=INDEX(OUT_FIL(1:LN),']')
	I=I+1
	J=INDEX(OUT_FIL(I:LN),'.')+I-2
	OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW',
     +	     FORM='FORMATTED',CARRIAGECONTROL='LIST',BLOCKSIZE=16384,
     +	     DEFAULTFILE='.DST',INITIALSIZE=10*IHS.W_DSTBLKS)
	CUR_VBN=IHS.L_DSTVBN
	CUR_VA=0
	ROUTINE_NAME=' '
	LN2=0
	DBG_RECS=0
	READ(1,REC=CUR_VBN) REC_BUF	! get 1st block of debug symbol table
	WRITE(2,9800)
 9800	FORMAT(';'/
     +	       ';  DEBUG Symbol Table analysis:')
	ADDR=0
	K=1
	DO WHILE (K.NE.0)
	  CALL COPY_BYTE(ADDR,K)
	  ADDR=ADDR+1
	  IF(K.NE.0)THEN
	    J=ADDR
	    I=0
	    CALL COPY_BYTE(J,I)
	    J=J+1
	    IF(I.EQ.'BE'X)THEN		! DST$K_RTNBEG routine begin
	      CALL COPY_BYTE(J,I3)	! MSB of byte set if JSB interface
	      J=J+1
	      CALL COPY_LONG(J,I2)	! address of routine
	      J=J+4
	      CALL COPY_STR(J,ROUTINE_NAME)	! name of routine
	      IF(MOD_START(MOD_TBL_PTR).EQ.-1)THEN	! if first routine in module,
		MOD_START(MOD_TBL_PTR)=I2		! save its start address
	      ENDIF
	      MOD_END(MOD_TBL_PTR)=I2			! save initial end address
	      CALL STR$TRIM(ROUTINE_NAME,ROUTINE_NAME,LN2)
	      WRITE(99,9801) I3, I2, ROUTINE_NAME(1:LN2)
 9801	      FORMAT(';     DST$K_RTNBEG: msk=',Z2.2,' adr=',Z8.8,
     +				' name=',A)
	      DO I=1,SYM_TBL_PTR
		IF(SYM_VAL(I).EQ.I2)THEN
		  SYM_NAM(I)=ROUTINE_NAME(1:LN2)
		  GOTO 1970
		ENDIF
	      ENDDO
	      IF((I3.AND.'80'X).EQ.0)THEN
		CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_PROC),,)
	      ELSE
		CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_SUBR),,)
	      ENDIF
	      SYM_NAM(SYM_TBL_PTR)=ROUTINE_NAME(1:LN2)
	    ELSEIF(I.EQ.'BF'X)THEN	! DST$K_RTNEND
	      J=J+1
	      CALL COPY_LONG(J,I2)
	      WRITE(99,9802) I2
9802	      FORMAT(';     DST$K_RTNEND:',I5,' bytes in routine')
	      ROUTINE_NAME=' '
	      LN2=0
	      MOD_END(MOD_TBL_PTR)=MOD_END(MOD_TBL_PTR)+I2-1
	    ELSEIF(I.EQ.'B0'X)THEN	! DST$K_BLKBEG block begin
	      J=J+1
	      CALL COPY_LONG(J,I2)	! address of block
	      J=J+4
	      CALL COPY_STR(J,BLOCK_NAME)	! name of block
	      CALL STR$TRIM(BLOCK_NAME,BLOCK_NAME,LN3)
	      WRITE(99,9803) I2, BLOCK_NAME(1:LN3)
9803	      FORMAT(';     DST$K_BLKBEG: adr=',Z8.8,' name=',A)
	      IF(LN3.NE.0)THEN		! only if block named
		DO I=1,SYM_TBL_PTR
		  IF(SYM_VAL(I).EQ.I2)THEN
		    SYM_NAM(I)=BLOCK_NAME(1:LN3)
		    GOTO 1970
		  ENDIF
		ENDDO
		CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,)
		SYM_NAM(SYM_TBL_PTR)=BLOCK_NAME(1:LN3)
	      ENDIF
	    ELSEIF(I.EQ.'B1'X)THEN	! DST$K_BLKEND
	      J=J+1
	      CALL COPY_LONG(J,I2)
	      WRITE(99,9804) I2
9804	      FORMAT(';     DST$K_BLKEND:',I5,' bytes in block')
	      BLOCK_NAME=' '
	      LN2=0
	    ELSEIF(I.EQ.'BA'X)THEN	! DST$K_LBLORLIT
	      CALL COPY_BYTE(J,I3)	! bottom two bits are value kind
	      J=J+1
	      CALL COPY_LONG(J,I2)	! value of label/literal
	      J=J+4
	      CALL COPY_STR(J,S_TMP)	! name of label/literal
	      I3=I3.AND.3	! extract only VALKIND field
	      CALL STR$TRIM(S_TMP,S_TMP,LN4)
	      WRITE(99,9805) I3, I2, S_TMP(1:LN4)
9805	      FORMAT(';     DST$K_LBLORLIT: kind=',I1,' val=',Z8.8,
     +					' name=',A)
	      IF(I3.EQ.1)THEN	! only if label is it put in symbol table
		DO I=1,SYM_TBL_PTR
		  IF(SYM_VAL(I).EQ.I2)THEN
		    SYM_NAM(I)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP
		    GOTO 1970
		  ENDIF
		ENDDO
		CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,)
		SYM_NAM(SYM_TBL_PTR)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP
	      ENDIF
	    ELSEIF(I.EQ.'B8'X)THEN	! DST$K_PSECT
	      J=J+1
	      CALL COPY_LONG(J,I2)
	      J=J+4
	      CALL COPY_STR(J,S_TMP)
	      CALL STR$TRIM(S_TMP,S_TMP,LN4)
	      J=J+1+LN4
	      CALL COPY_LONG(J,I3)
	      WRITE(99,9806) I2, I3, S_TMP(1:LN4)
9806	      FORMAT(';     DST$K_PSECT: start adr=',Z8.8,
     +				I8,' bytes, name=',A)
	      CALL WRITE_PSECT_TBL(I2,S_TMP(1:LN4),-1,-1,I3)
	    ELSEIF(I.EQ.'BB'X)THEN	! DST$K_LABEL
	      J=J+1
	      CALL COPY_LONG(J,I2)
	      J=J+4
	      CALL COPY_STR(J,S_TMP)
	      CALL STR$TRIM(S_TMP,S_TMP,LN4)
	      WRITE(99,9807) I2, S_TMP(1:LN4)
9807	      FORMAT(';     DST$K_LABEL: val=',Z8.8,' name=',A)
	      DO I=1,SYM_TBL_PTR
		IF(SYM_VAL(I).EQ.I2)THEN
		  SYM_NAM(I)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP
		  GOTO 1970
		ENDIF
	      ENDDO
	      CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,)
	      SYM_NAM(SYM_TBL_PTR)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP
	    ELSEIF(I.EQ.'BC'X)THEN	! DST$K_MODBEG
	      MOD_TBL_PTR=MOD_TBL_PTR+1
	      J=J+1
	      CALL COPY_LONG(J,I3)	! language type
	      MOD_LNG(MOD_TBL_PTR)=I3
	      J=J+4
	      CALL COPY_STR(J,MOD_NAM(MOD_TBL_PTR))
	      CALL STR$TRIM(MOD_NAM(MOD_TBL_PTR),
     +			    MOD_NAM(MOD_TBL_PTR),LN)
	      WRITE(99,9808) MOD_NAM(MOD_TBL_PTR)(1:LN), LANGUAGE_NAME(I3)
9808	      FORMAT(';     DST$K_MODBEG: name=',A,' language=',A)
	      MOD_START(MOD_TBL_PTR)=-1
	      MOD_VERMAJ(MOD_TBL_PTR)=0
	      MOD_VERMIN(MOD_TBL_PTR)=0
	      CURRENT_LINE=0
	      CURRENT_STMT=1
	      CURRENT_INCR=1
	      CURRENT_STMT_MODE=.FALSE.
	      CURRENT_PC=-1
	      CURRENT_MARK=.FALSE.
	    ELSEIF(I.EQ.'BD'X)THEN	! DST$K_MODEND
	      WRITE(99,9809)
9809	      FORMAT(';     DST$K_MODEND')
	      OLD_MODTB_PTR=MOD_TBL_PTR
	    ELSEIF(I.EQ.'B5'X)THEN	! DST$K_ENTRY
	      J=J+1
	      CALL COPY_LONG(J,I2)
	      J=J+4
	      CALL COPY_STR(J,S_TMP)
	      CALL STR$TRIM(S_TMP,S_TMP,LN4)
	      WRITE(99,9810) I2, S_TMP(1:LN4)
9810	      FORMAT(';     DST$K_ENTRY: val=',Z8.8,' name=',A)
	      DO I=1,SYM_TBL_PTR
		IF(SYM_VAL(I).EQ.I2)THEN
		  SYM_TYP(I)=SYM_TYP(I).OR.SYM_PROC
		  SYM_NAM(I)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP
		  GOTO 1970
		ENDIF
	      ENDDO
	      CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_PROC),,)
	      SYM_NAM(SYM_TBL_PTR)=MOD_NAM(MOD_TBL_PTR)(1:LN)//'_'//S_TMP
	    ELSEIF(I.EQ.'A2'X)THEN	! DST$K_PROLOG
	      CALL COPY_LONG(J,I2)
	      WRITE(99,9811) I2
9811	      FORMAT(';     DST$K_PROLOG: adr=',Z8.8)
	      DO I=1,SYM_TBL_PTR
		IF(SYM_VAL(I).EQ.I2)THEN
		  SYM_TYP(I)=SYM_TYP(I).OR.SYM_JMPE
		  SYM_NAM(I)='PROLOG_'//ROUTINE_NAME(1:LN2)
		  GOTO 1970
		ENDIF
	      ENDDO
	      CALL WRITE_SYM_TBL(%VAL(I2),%VAL(SYM_JMPE),,)
	      SYM_NAM(SYM_TBL_PTR)='PROLOG_'//ROUTINE_NAME(1:LN2)
	    ELSEIF(I.EQ.'B9'X)THEN	! DST$K_LINE_NUM
	      IF(CURRENT_PC.EQ.-1)THEN
		CURRENT_PC=MOD_START(MOD_TBL_PTR)
	      ENDIF
	      WRITE(99,9812) K, CURRENT_PC
9812	      FORMAT(';     DST$K_LINE_NUM: ln=',I3,' current PC=',Z8.8)
	      DO WHILE (J.LT.ADDR+K)
		CALL COPY_BYTE(J,OK)
		J=J+1
		IF(OK.GE.-128.AND.OK.LE.0)THEN		! delta PC
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=CURRENT_STMT+1
		  ELSE
		    CURRENT_LINE=CURRENT_LINE+CURRENT_INCR
		  ENDIF
		  CURRENT_MARK=.TRUE.
		  CURRENT_PC=CURRENT_PC-OK
		  WRITE(99,9850) CURRENT_LINE, CURRENT_STMT, CURRENT_PC
 9850		  FORMAT(';',9X,'delta PC byte, line',I5,'.',I2.2,
     +				' PC=',Z8.8)
		  LIN_TBL_PTR=LIN_TBL_PTR+1
		  LIN_ADR(LIN_TBL_PTR)=CURRENT_PC
		  LIN_NUM(LIN_TBL_PTR)=CURRENT_LINE
		  LIN_STMT(LIN_TBL_PTR)=CURRENT_STMT
		ELSEIF(OK.EQ.1)THEN			! DST$K_DELTA_PC_W
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=CURRENT_STMT+1
		  ELSE
		    CURRENT_LINE=CURRENT_LINE+CURRENT_INCR
		  ENDIF
		  CURRENT_MARK=.TRUE.
		  I2=0
		  CALL COPY_WORD(J,I2)
		  J=J+2
		  CURRENT_PC=CURRENT_PC+I2
 		  WRITE(99,9851) CURRENT_LINE, CURRENT_STMT, CURRENT_PC
 9851		  FORMAT(';',9X,'delta PC word, line',I5,'.',I2.2,
     +					' PC=',Z8.8)
		  LIN_TBL_PTR=LIN_TBL_PTR+1
		  LIN_ADR(LIN_TBL_PTR)=CURRENT_PC
		  LIN_NUM(LIN_TBL_PTR)=CURRENT_LINE
		  LIN_STMT(LIN_TBL_PTR)=CURRENT_STMT
		ELSEIF(OK.EQ.2)THEN			! DST$K_INCR_LINUM
		  I2=0
		  CALL COPY_BYTE(J,I2)
		  J=J+1
		  CURRENT_LINE=CURRENT_LINE+I2
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=1
		  ENDIF
 		  WRITE(99,9852) CURRENT_LINE, CURRENT_STMT
 9852		  FORMAT(';',9X,'incr linum byte, line',I5,'.',I2.2)
		ELSEIF(OK.EQ.3)THEN			! DST$K_INCR_LINUM_W
		  I2=0
		  CALL COPY_WORD(J,I2)
		  J=J+2
		  CURRENT_LINE=CURRENT_LINE+I2
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=1
		  ENDIF
 		  WRITE(99,9853) CURRENT_LINE, CURRENT_STMT
 9853		  FORMAT(';',9X,'incr linum word, line',I5,'.',I2.2)
		ELSEIF(OK.EQ.4)THEN			! DST$K_SET_LINUM_INCR
		  CURRENT_INCR=0
		  CALL COPY_BYTE(J,CURRENT_INCR)
		  J=J+1
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=1
		  ENDIF
 		  WRITE(99,9854) CURRENT_INCR
 9854		  FORMAT(';',9X,'set linum incr byte, incr=',I4)
		ELSEIF(OK.EQ.5)THEN			! DST$K_SET_LINUM_INCR_W
		  CURRENT_INCR=0
		  CALL COPY_WORD(J,CURRENT_INCR)
		  J=J+2
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=1
		  ENDIF
 		  WRITE(99,9855) CURRENT_INCR
 9855		  FORMAT(';',9X,'set linum incr word, incr=',I4)
		ELSEIF(OK.EQ.6)THEN			! DST$K_RESET_LINUM_INCR
		  CURRENT_INCR=1
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=1
		  ENDIF
 		  WRITE(99,9856)
 9856		  FORMAT(';',9X,'reset linum incr')
		ELSEIF(OK.EQ.7)THEN			! DST$K_BEG_STMT_MODE
		  CURRENT_STMT=1
		  CURRENT_STMT_MODE=.TRUE.
 		  WRITE(99,9857)
 9857		  FORMAT(';',9X,'begin stmt mode')
		  IF(.NOT.CURRENT_MARK) WRITE(99,9872)
 9872 FORMAT(';',14X,'*** invalid DST record - line currently closed')
		ELSEIF(OK.EQ.8)THEN			! DST$K_END_STMT_MODE
		  CURRENT_STMT=1
		  CURRENT_STMT_MODE=.FALSE.
 		  WRITE(99,9858)
 9858		  FORMAT(';',9X,'end stmt mode')
		ELSEIF(OK.EQ.9)THEN			! DST$K_SET_LINUM
		  CURRENT_LINE=0
		  CALL COPY_WORD(J,CURRENT_LINE)
		  J=J+2
 		  WRITE(99,9859) CURRENT_LINE
 9859		  FORMAT(';',9X,'set linum word, line',I5)
		ELSEIF(OK.EQ.10)THEN			! DST$K_SET_PC
		  CURRENT_PC=0
		  CALL COPY_BYTE(J,CURRENT_PC)
		  J=J+1
		  CURRENT_PC=MOD_START(MOD_TBL_PTR)+CURRENT_PC
 		  WRITE(99,9860) CURRENT_PC
 9860		  FORMAT(';',9X,'set PC byte, PC=',Z8.8)
		  IF(.NOT.CURRENT_MARK) WRITE(99,9872)
		ELSEIF(OK.EQ.11)THEN			! DST$K_SET_PC_W
		  CURRENT_PC=0
		  CALL COPY_WORD(J,CURRENT_PC)
		  J=J+2
		  CURRENT_PC=MOD_START(MOD_TBL_PTR)+CURRENT_PC
 		  WRITE(99,9861) CURRENT_PC
 9861		  FORMAT(';',9X,'set PC word, PC=',Z8.8)
		  IF(.NOT.CURRENT_MARK) WRITE(99,9872)
		ELSEIF(OK.EQ.12)THEN			! DST$K_SET_PC_L
		  CALL COPY_LONG(J,CURRENT_PC)
		  J=J+4
		  CURRENT_PC=MOD_START(MOD_TBL_PTR)+CURRENT_PC
 		  WRITE(99,9862) CURRENT_PC
 9862		  FORMAT(';',9X,'set PC longword, PC=',Z8.8)
		  IF(.NOT.CURRENT_MARK) WRITE(99,9872)
		ELSEIF(OK.EQ.13)THEN			! DST$K_SET_STMTNUM
		  CURRENT_STMT=0
		  CALL COPY_WORD(J,CURRENT_STMT)
		  J=J+2
 		  WRITE(99,9863) CURRENT_PC
 9863		  FORMAT(';',9X,'set stmtnum, stmt',I3.2)
		ELSEIF(OK.EQ.14)THEN			! DST$K_TERM
		  I2=0
		  CALL COPY_BYTE(J,I2)
		  J=J+1
		  CURRENT_PC=CURRENT_PC+I2
		  CURRENT_MARK=.FALSE.
 		  WRITE(99,9864) CURRENT_PC
 9864		  FORMAT(';',9X,'term byte, PC=',Z8.8)
		ELSEIF(OK.EQ.15)THEN			! DST$K_TERM_W
		  I2=0
		  CALL COPY_WORD(J,I2)
		  J=J+2
		  CURRENT_PC=CURRENT_PC+I2
		  CURRENT_MARK=.FALSE.
 		  WRITE(99,9865) CURRENT_PC
 9865		  FORMAT(';',9X,'term word, PC=',Z8.8)
		ELSEIF(OK.EQ.16)THEN			! DST$K_SET_ABS_PC
		  CALL COPY_LONG(J,CURRENT_PC)
		  J=J+4
 		  WRITE(99,9866) CURRENT_PC
 9866		  FORMAT(';',9X,'set abs PC, PC=',Z8.8)
		  IF(.NOT.CURRENT_MARK) WRITE(99,9872)
		ELSEIF(OK.EQ.17)THEN			! DST$K_DELTA_PC_L
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=CURRENT_STMT+1
		  ELSE
		    CURRENT_LINE=CURRENT_LINE+CURRENT_INCR
		  ENDIF
		  CURRENT_MARK=.TRUE.
		  CALL COPY_LONG(J,I2)
		  J=J+4
		  CURRENT_PC=CURRENT_PC+I2
 		  WRITE(99,9867) CURRENT_LINE, CURRENT_STMT, CURRENT_PC
 9867		  FORMAT(';',9X,'delta PC long, line',
     +				I5,'.',I2.2,' PC=',Z8.8)
		  LIN_TBL_PTR=LIN_TBL_PTR+1
		  LIN_ADR(LIN_TBL_PTR)=CURRENT_PC
		  LIN_NUM(LIN_TBL_PTR)=CURRENT_LINE
		  LIN_STMT(LIN_TBL_PTR)=CURRENT_STMT
		ELSEIF(OK.EQ.18)THEN			! DST$K_INCR_LINUM_L
		  CALL COPY_LONG(J,I2)
		  J=J+4
		  CURRENT_LINE=CURRENT_LINE+I2
		  IF(CURRENT_STMT_MODE)THEN
		    CURRENT_STMT=1
		  ENDIF
 		  WRITE(99,9868) CURRENT_LINE, CURRENT_STMT
 9868		  FORMAT(';',9X,'incr linum long, line',I5,'.',I2.2)
		ELSEIF(OK.EQ.19)THEN			! DST$K_SET_LINUM_B
		  CURRENT_LINE=0
		  CALL COPY_BYTE(J,CURRENT_LINE)
		  J=J+1
 		  WRITE(99,9869) CURRENT_LINE
 9869		  FORMAT(';',9X,'set linum byte, line',I5)
		ELSEIF(OK.EQ.20)THEN			! DST$K_SET_LINUM_L
		  CALL COPY_LONG(J,CURRENT_LINE)
		  J=J+4
 		  WRITE(99,9870) CURRENT_LINE
 9870		  FORMAT(';',9X,'set linum long, line',I5)
		ELSEIF(OK.EQ.21)THEN			! DST$K_TERM_L
		  CALL COPY_LONG(J,I2)
		  J=J+4
		  CURRENT_PC=CURRENT_PC+I2
		  CURRENT_MARK=.FALSE.
 		  WRITE(99,9871) CURRENT_PC
 9871		  FORMAT(';',9X,'term long, PC=',Z8.8)
		ELSE
		  WRITE(99,9873) OK
 9873		  FORMAT(';',9X,'unknown linum command code=',Z2.2)
		ENDIF
	      ENDDO
	    ELSEIF(I.EQ.'99'X)THEN	! DST$K_VERSION
	      I2=0
	      CALL COPY_BYTE(J,I2)
	      MOD_VERMAJ(MOD_TBL_PTR)=I2
	      I3=0
	      J=J+1
	      CALL COPY_BYTE(J,I3)
	      MOD_VERMIN(MOD_TBL_PTR)=I2
 	      WRITE(99,9813) I2, I3
 9813	      FORMAT(';     DST$K_VERSION: V',I2.2,'.',I2.2)
	    ELSEIF(I.GE.0.AND.I.LE.37)THEN
	      WRITE(99,9897) K, I
 9897	      FORMAT(';     DST$K_???: ln=',I3,' valid data type code=',I3,
     +				' unrecog. by DISM-32')
	    ELSEIF(I.GE.'99'X.AND.I.LE.'BF'X)THEN
	      WRITE(99,9898) K, I
 9898	      FORMAT(';     DST$K_???: ln=',I3,' valid type code=',I3,
     +				' unrecog. by DISM-32')
	    ELSE
	      WRITE(99,9899) K, I
 9899	      FORMAT(';     DST$K_??????: ln=',I3,
     +				' invalid type code=',I3)
	    ENDIF
 1970	    ADDR=ADDR+K
	    DBG_RECS=DBG_RECS+1
	  ENDIF
	ENDDO
	WRITE(99,9890) DBG_RECS
	WRITE(2,9890) DBG_RECS
 9890	FORMAT(';    ',I5,' DEBUG symbol table records extracted')
	CLOSE(UNIT=99)
	CALL SYS$FAOL('DST analyzed, !SW records found',LN,
     +			OUT_FIL,DBG_RECS)
	CALL LIB$PUT_OUTPUT(OUT_FIL(1:LN))
      ENDIF
      CALL LIB$REVERT
C
C  begin pass 1 disassembly
C
      CALL LIB$PUT_OUTPUT('Beginning pass 1...')
      CALL LIB$ESTABLISH(FIX_BUFR_OVRFL)
  100 OK=.TRUE.
      DO WHILE (OK)
C
C  search for an undisassembled code entry point
C
	OLD_SMTB_PTR=SYM_TBL_PTR
	DO I=1,OLD_SMTB_PTR
	  IF((SYM_TYP(I).AND.(SYM_M_CODE.AND..NOT.SYM_TRANSFER)).NE.0.AND.
     +	     (SYM_TYP(I).AND.SYM_DISM).EQ.0)THEN
	    SYM_TYP(I)=SYM_TYP(I).OR.SYM_DISM
C
C  a good symbol to disassemble from has been found, find what image
C    section it is in
C
	    DO J=1,ISD_NUM
	      IF(ISD_BASEVA(J).LE.SYM_VAL(I).AND.
     +		 ISD_PGEND(J).GE.SYM_VAL(I))THEN
		ISD(J).W_SIZE=-IABS(ISD(J).W_SIZE)
C
C  if symbol is in this image section, only disassemble it if in this
C    image file (as opposed to a shareable image linked to it)
C
		IF(ISD(J).L_VBN .NE.0.AND.
     +		   (ISD(J).L_FLAGS .AND.1).EQ.0)THEN	! ISD$M_GBL
		  CUR_VBN=ISD(J).L_VBN+INT((SYM_VAL(I)-
     +			ISD_BASEVA(J))/512)
		  CUR_VA=(SYM_VAL(I).AND..NOT.'1FF'X)
		  READ(1,REC=CUR_VBN) REC_BUF
		  ADDR=SYM_VAL(I)
		  IF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN
		    ADDR=ADDR+2
		    K=0
		    CALL COPY_WORD(ADDR,K)
		    IF(K.EQ.'EFDE'X)THEN	! MOVAL L^xxxx,-
		      K=0
		      CALL COPY_BYTE(ADDR+6,K)
		      IF(K.EQ.'4B'X)THEN	! R11
			CALL COPY_LONG(ADDR+2,K)
			K=K+ADDR+6
			CALL WRITE_SYM_TBL(%VAL(K),%VAL(SYM_BASEADR),,)
		      ENDIF
		    ENDIF
		  ENDIF
C
C  disassemble until unconditional transfer instruction
C
		  K=1
		  DO WHILE (K.EQ.1)
		    K=DISM_INSTR(ADDR,0)
		    IF(K.EQ.%LOC(DISM__INVOPCODE))THEN
		      CALL LIB$SIGNAL(%VAL(K),%VAL(1),%VAL(ADDR-1))
		    ENDIF
		  ENDDO
		  GOTO 1900
		ENDIF
	      ENDIF
	    ENDDO
	  ENDIF
 1900	  CONTINUE
	ENDDO
C
C  test if all symbols have been processed, and exit if no new symbols
C    have been added to the symbol table
C
	IF(OLD_SMTB_PTR.EQ.SYM_TBL_PTR)OK=.FALSE.
      ENDDO
C
C  enlarge working set to maximum allowed by quotas
C
      ICODE=SYS$ADJWSL(%VAL(1000),)
      IF(.NOT.ICODE)CALL LIB$SIGNAL(%VAL(ICODE))
      CALL SYS$FAOL('Beginning symbol table analysis, !SL symbols...',
     +		    LN,OUT_FIL,SYM_TBL_PTR)
      CALL LIB$PUT_OUTPUT(OUT_FIL(1:LN))
C
C  pre-scan symbol table to analyze complex data structures
C
      SYM_FOUND_NEW_CODE=.FALSE.
      CALL EXTENDED_DATA_SYMTBL
      IF(SYM_FOUND_NEW_CODE)THEN
	CALL LIB$PUT_OUTPUT('Found more code symbols, rerunning pass 1...')
	GOTO 100
      ENDIF
C
C  shell-sort the symbol table into ascending address order
C
      I9=(2**INT(LOG(FLOAT(MAX(SYM_TBL_PTR,1)))/LOG(2.0))) - 1
      DO WHILE (I9.GT.0)
	DO I=1,SYM_TBL_PTR-I9
	  IF(SYM_VAL(I).GT.SYM_VAL(I+I9))THEN
	    I2=SYM_VAL(I+I9)
	    I3=SYM_TYP(I+I9)
	    ROUTINE_NAME=SYM_NAM(I+I9)
	    LN=SYM_EXT_ATTR(I+I9)
	    K=SYM_EXT_VAL(I+I9)
	    SYM_VAL(I+I9)=SYM_VAL(I)
	    SYM_TYP(I+I9)=SYM_TYP(I)
	    SYM_NAM(I+I9)=SYM_NAM(I)
	    SYM_EXT_ATTR(I+I9)=SYM_EXT_ATTR(I)
	    SYM_EXT_VAL(I+I9)=SYM_EXT_VAL(I)
	    IF(I.GT.I9)THEN
	      J=I-I9
	      DO WHILE (J.GE.1.AND.I2.LT.SYM_VAL(J))
		SYM_VAL(J+I9)=SYM_VAL(J)
		SYM_TYP(J+I9)=SYM_TYP(J)
		SYM_NAM(J+I9)=SYM_NAM(J)
		SYM_EXT_ATTR(J+I9)=SYM_EXT_ATTR(J)
		SYM_EXT_VAL(J+I9)=SYM_EXT_VAL(J)
		J=J-I9
	      ENDDO
	      SYM_VAL(J+I9)=I2
	      SYM_TYP(J+I9)=I3
	      SYM_NAM(J+I9)=ROUTINE_NAME
	      SYM_EXT_ATTR(J+I9)=LN
	      SYM_EXT_VAL(J+I9)=K
	    ELSE
	      SYM_VAL(I)=I2
	      SYM_TYP(I)=I3
	      SYM_NAM(I)=ROUTINE_NAME
	      SYM_EXT_ATTR(I)=LN
	      SYM_EXT_VAL(I)=K
	    ENDIF
	  ENDIF
	ENDDO
	I9=I9/2
      ENDDO
C
C  shell-sort the line number table into ascending address order
C
      IF(LIN_TBL_PTR.NE.0)THEN
	I9=(2**INT(LOG(FLOAT(LIN_TBL_PTR))/LOG(2.0))) - 1
	DO WHILE (I9.GT.0)
	  DO I=1,LIN_TBL_PTR-I9
	    IF(LIN_ADR(I).GT.LIN_ADR(I+I9))THEN
	      I2=LIN_ADR(I+I9)
	      LN=LIN_NUM(I+I9)
	      LN2=LIN_STMT(I+I9)
	      LIN_ADR(I+I9)=LIN_ADR(I)
	      LIN_NUM(I+I9)=LIN_NUM(I)
	      LIN_STMT(I+I9)=LIN_STMT(I)
	      IF(I.GT.I9)THEN
		J=I-I9
		DO WHILE (J.GE.1.AND.I2.LT.LIN_ADR(J))
		  LIN_ADR(J+I9)=LIN_ADR(J)
		  LIN_NUM(J+I9)=LIN_NUM(J)
		  LIN_STMT(J+I9)=LIN_STMT(J)
		  J=J-I9
		ENDDO
		LIN_ADR(J+I9)=I2
		LIN_NUM(J+I9)=LN
		LIN_STMT(J+I9)=LN2
	      ELSE
		LIN_ADR(I)=I2
		LIN_NUM(I)=LN
		LIN_STMT(I)=LN2
	      ENDIF
	    ENDIF
	  ENDDO
	  I9=I9/2
	ENDDO
      ENDIF
C
C  open SYS$LIBRARY:STARLET.OLB to read some symbol definition modules
C
      ICODE=LBR$INI_CONTROL(LIBRARY_INDEX,LBR$C_READ)
      IF(.NOT.ICODE)THEN
	CALL LIB$SIGNAL(%VAL(ICODE))
      ENDIF
      ICODE=LBR$OPEN(LIBRARY_INDEX,'SYS$LIBRARY:STARLET.OLB')
      IF(.NOT.ICODE)THEN
	CALL LIB$SIGNAL(%VAL(ICODE))
      ENDIF
C
C  read in and analyze the SYS$P1_VECTORS module to resolve more symbols
C
      ICODE=LBR$LOOKUP_KEY(LIBRARY_INDEX,'SYS$P1_VECTOR',I_FLT)
      IF(.NOT.ICODE)THEN
	CALL LIB$SIGNAL(%VAL(ICODE))
      ELSE
	DO WHILE (ICODE)
	  ICODE=LBR$GET_RECORD(LIBRARY_INDEX,S_TMP,I_FLT)
	  REC_TYP=ICHAR(S_TMP(1:1))
	  REC_SUBTYP=ICHAR(S_TMP(2:2))
	  IF(ICODE)THEN
	    ICODE=ANALYZE_SYM_REC(REC_TYP,REC_SUBTYP,
     +				S_TMP(3:MAX(I_FLT(1),3)),-1,0)
	    ICODE=ICODE.EQ.0
	  ENDIF
	ENDDO
      ENDIF
C
C  read in and analyze the RMS$GLOBALS module to resolve more symbols
C
      ICODE=LBR$LOOKUP_KEY(LIBRARY_INDEX,'RMS$GLOBALS',I_FLT)
      IF(.NOT.ICODE)THEN
	CALL LIB$SIGNAL(%VAL(ICODE))
      ELSE
	DO WHILE (ICODE)
	  ICODE=LBR$GET_RECORD(LIBRARY_INDEX,S_TMP,I_FLT)
	  REC_TYP=ICHAR(S_TMP(1:1))
	  REC_SUBTYP=ICHAR(S_TMP(2:2))
	  IF(ICODE)THEN
	    ICODE=ANALYZE_SYM_REC(REC_TYP,REC_SUBTYP,
     +				S_TMP(3:MAX(I_FLT(1),3)),-1,0)
	    ICODE=ICODE.EQ.0
	  ENDIF
	ENDDO
      ENDIF
C
C  close the system object library file
C
      ICODE=LBR$CLOSE(LIBRARY_INDEX)
      IF(.NOT.ICODE)THEN
	CALL LIB$SIGNAL(%VAL(ICODE))
      ENDIF
C
C  read in and analyze SYS$SYSTEM:SYS.STB to resolve more symbols
C
      OPEN(UNIT=3,FILE='SYS$SYSTEM:SYS.STB',ACCESS='SEQUENTIAL',
     +	READONLY,FORM='FORMATTED',ORGANIZATION='SEQUENTIAL',
     +	RECORDTYPE='VARIABLE',STATUS='OLD',IOSTAT=ICODE,SHARED)
      IF(ICODE.NE.0)THEN
	CALL LIB$SIGNAL(DISM__BADSYSSTB,%VAL(1),%VAL(ICODE))
      ELSE
	DO WHILE (ICODE.EQ.0)
	  READ(3,9100,IOSTAT=ICODE) REC_TYP,REC_SUBTYP,LN,S_TMP
 9100	  FORMAT(A1,A1,Q,A)
	  IF(ICODE.EQ.0)THEN
	    ICODE=ANALYZE_SYM_REC(REC_TYP,REC_SUBTYP,S_TMP(1:MAX(LN,1)),-1,0)
	  ENDIF
	ENDDO
	CLOSE(UNIT=3)
      ENDIF
C
C  assign names to ISD's that haven't had names assigned to them yet (so
C	they can be used as PSECT names)
C
      MSG_NUMFAC=0
      DO I=1,ISD_NUM
	IF(ISD_NAM(I).EQ.' ')THEN
	  IF(JISHFT(ISD(I).L_FLAGS,-24).EQ.-3.OR.
     +	     JISHFT(ISD(I).L_FLAGS,-24).EQ.253)THEN
	    ISD_NAM(I)='$USRSTACK'
	  ELSEIF((ISD(I).L_FLAGS .AND.1).NE.0)THEN	! if shareable image section
	    ISD_NAM(I)=ISD(I).T_GBLNAM(1:ISD(I).B_GBLNAMLEN)//'_SEC'
	  ELSEIF((ISD(I).L_FLAGS .AND.'400'X).NE.0)THEN	! ISD$M_FIXUPVEC
	    CALL SYS$FAO('$FIXUPSEC_!UL',,ISD_NAM(I),%VAL(I))
	    FIXUPSEC_ISD=I
	  ELSEIF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)THEN ! ISD$M_VECTOR
	    CUR_VBN=ISD(I).L_VBN
	    READ(1,REC=CUR_VBN) REC_BUF
	    CUR_VA=ISD_BASEVA(I)
	    CALL LIB$MOVC3(32,REC_BUF(0),PLV)	! get privileged vector block
	    IF(PLV.L_TYPE .EQ.1)THEN	! change mode vector, privileged
	      CALL SYS$FAO('$PLVECT_!UL',,ISD_NAM(I),%VAL(I))
	    ELSEIF(PLV.L_TYPE .EQ.2)THEN	! message vector
	      CALL SYS$FAO('$MSGVEC_!UL',,ISD_NAM(I),%VAL(I))
	      AUX_SYM_TBL(-1)=0
	      ADDR=ISD_BASEVA(I)+16
	      AUX_SYM_TBL(0)=-1
	      DO WHILE (AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0)
		AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)+1
		CALL COPY_LONG(ADDR,AUX_SYM_TBL(AUX_SYM_TBL(-1)))	! get offset
		IF(AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0)THEN
		  AUX_SYM_TBL(AUX_SYM_TBL(-1))=AUX_SYM_TBL(AUX_SYM_TBL(-1))+ADDR
		ENDIF
		ADDR=ADDR+4
	      ENDDO
	      AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)-1
	      DO I2=1,AUX_SYM_TBL(-1)
		ADDR=AUX_SYM_TBL(I2)
		CALL COPY_WORD(ADDR,LN)	! get message section type
		ADDR=ADDR+4
		CALL COPY_LONG(ADDR,I3)	! get section length
		ADDR=ADDR+4
		IF(LN.EQ.0)THEN		! if actual definitions here
		  MSG_NUMFAC=MSG_NUMFAC+1
		  CALL COPY_LONG(ADDR,MSG_FACDESCR(1,MSG_NUMFAC)) ! get offset to vector index
		  MSG_FACDESCR(1,MSG_NUMFAC)=MSG_FACDESCR(1,MSG_NUMFAC)
     +					+AUX_SYM_TBL(I2)
		  ADDR=ADDR+4
		  CALL COPY_LONG(ADDR,MSG_FACDESCR(2,MSG_NUMFAC)) ! get offset to facility name
		  MSG_FACDESCR(2,MSG_NUMFAC)=MSG_FACDESCR(2,MSG_NUMFAC)
     +					+AUX_SYM_TBL(I2)
		  ADDR=ADDR+4
		  CALL COPY_LONG(ADDR,MSG_FACDESCR(3,MSG_NUMFAC)) ! get offset to string area
		  MSG_FACDESCR(3,MSG_NUMFAC)=MSG_FACDESCR(3,MSG_NUMFAC)
     +					+AUX_SYM_TBL(I2)
		  CALL COPY_WORD(MSG_FACDESCR(3,MSG_NUMFAC),LN2)
		  DO K=1,LN2
		    CALL COPY_BYTE(MSG_FACDESCR(3,MSG_NUMFAC)+1+K,
     +				   %REF(FACILITY_BUF(K:K)))
		  ENDDO
		  MSG_FACDESCR(4,MSG_NUMFAC)=FACILITY_NUMBER
		ENDIF
	      ENDDO
	    ELSE
	      CALL SYS$FAO('$UNKN_VEC_!UL',,ISD_NAM(I),%VAL(I))
	    ENDIF
	  ELSEIF((ISD(I).L_FLAGS .AND.8).NE.0.AND.	! ISD$M_WRT
     +		 ISD(I).W_SIZE .LT.0)THEN
	    CALL SYS$FAO('$IMPURE_!UL',,ISD_NAM(I),%VAL(I))
	  ELSEIF(ISD(I).W_SIZE .LT.0)THEN
	    CALL SYS$FAO('$CODE_!UL',,ISD_NAM(I),%VAL(I))
	  ELSEIF((ISD(I).L_FLAGS.AND.8).NE.0)THEN	! ISD$M_WRT
	    CALL SYS$FAO('$LOCAL_!UL',,ISD_NAM(I),%VAL(I))
	  ELSE
	    CALL SYS$FAO('$PDATA_!UL',,ISD_NAM(I),%VAL(I))
	  ENDIF
	ENDIF
      ENDDO
C
C  if a fixup section is defined then
C
      IF(FIXUPSEC_ISD.NE.0)THEN
C
C  do fixup section analysis
C
	DO I=0,ISD(FIXUPSEC_ISD).W_PAGCNT-1
	  READ (1,REC=ISD(FIXUPSEC_ISD).L_VBN+I)
     +			(HDR_BUF(J),J=I*512,(I+1)*512-1)
	ENDDO
	CALL LIB$MOVC3(IAF$S_SIZE,HDR_BUF(0),IAF)
	IF((IHD.L_LNKFLAGS .AND.'20'X).NE.0)THEN
	  J=SHL$S_SIZE
	ELSE
	  J=SHL$S_SIZE_V3
	ENDIF
	DO K=1,IAF.L_SHRIMGCNT
	  CALL LIB$MOVC3(J,
     +			 HDR_BUF(IAF.L_SHLSTOFF+(K-1)*J),
     +			 FIX_SHL(K-1))
	ENDDO
	FIX_SHL(0).T_IMGNAM='this image'
	FIX_SHL(0).B_IMGNAMLEN=10
	DO K=1,SYM_TBL_PTR
	  IF(SYM_VAL(K).GE.ISD_BASEVA(FIXUPSEC_ISD).AND.
     +	     SYM_VAL(K).LE.ISD_PGEND(FIXUPSEC_ISD).AND.
     +	     (SYM_TYP(K).AND.SYM_D_LNG).NE.0)THEN
	    SYM_TYP(K)=SYM_TYP(K).OR.SYM_G_FIXUP
	  ENDIF
	ENDDO
	J=IAF.L_G_FIXOFF
	I9=1
	DO WHILE (HDR_BUF(J).NE.0.AND.J.NE.0)
	  CALL LIB$MOVC3(8,HDR_BUF(J),OFFSET_VEC(0))
	  DO I8=1,OFFSET_VEC(0)
	    DO WHILE (I9.LE.SYM_TBL_PTR.AND.
     +		      SYM_VAL(I9).LT.J+4+ISD_BASEVA(FIXUPSEC_ISD)+4*I8)
	      I9=I9+1
	    ENDDO
	    IF(SYM_VAL(I9).GT.J+4+ISD_BASEVA(FIXUPSEC_ISD)+4*I8)THEN
	      DO I2=SYM_TBL_PTR,I9,-1
		SYM_VAL(I2+1)=SYM_VAL(I2)
		SYM_TYP(I2+1)=SYM_TYP(I2)
		SYM_NAM(I2+1)=SYM_NAM(I2)
		SYM_EXT_ATTR(I2+1)=SYM_EXT_ATTR(I2)
		SYM_EXT_VAL(I2+1)=SYM_EXT_VAL(I2)
	      ENDDO
	      SYM_TBL_PTR=SYM_TBL_PTR+1
	      SYM_VAL(I9)=J+4+ISD_BASEVA(FIXUPSEC_ISD)+4*I8
	      SYM_TYP(I9)=SYM_G_FIXUP+SYM_D_LNG
	      SYM_NAM(I9)=' '
	      SYM_EXT_ATTR(I9)=0
	      SYM_EXT_VAL(I9)=0
	    ENDIF
	  ENDDO
	  J=J+8+OFFSET_VEC(0)*4
	ENDDO
C
C  read in and analyze system shareable images to resolve more symbols
C    if any were linked into image
C
	DO I=1,IAF.L_SHRIMGCNT-1
	  CALL LIB$ESTABLISH(FIX_BUF_3)
	  J=FIX_SHL(I).B_IMGNAMLEN
	  IF(FIX_SHL(I).T_IMGNAM(1:J).EQ.'VMSRTL')THEN
	    I_FLT(1)=JISHFT(JPI$_IMAGNAME,16)+LEN(S_TMP)
	    I_FLT(2)=%LOC(S_TMP)
	    I_FLT(3)=%LOC(LN)
	    I_FLT(4)=0
	    CALL SYS$GETJPI(,,,I_FLT,,,) ! get full filespec of DISM32.EXE
	    I_FLT(1)=JISHFT(FSCN$_NAME,16)
	    I_FLT(2)=0
	    I_FLT(3)=0
	    CALL SYS$FILESCAN(S_TMP(1:LN),I_FLT,)
	    I2=I_FLT(2)-%LOC(S_TMP)
	    OPEN(UNIT=3,FILE=S_TMP(1:I2)//'VMSRTL_V3.EXE',ACCESS='DIRECT',
     +		 READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL',
     +		 RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE,
     +		 SHARED)
	  ELSE
	    OPEN(UNIT=3,FILE=FIX_SHL(I).T_IMGNAM(1:J),ACCESS='DIRECT',
     +		 READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL',
     +		 RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE,
     +		 DEFAULTFILE='SYS$SHARE:.EXE',SHARED)
	  ENDIF
	  IF(ICODE.NE.0)THEN
	    CALL LIB$SIGNAL(DISM__BADSHRIMG,%VAL(2),%VAL(ICODE),
     +		%DESCR(FIX_SHL(I).T_IMGNAM(1:J)))
	  ELSE
	    OFFSET_VEC(0)=-1
	    OFFSET_VEC(1)=0
	    J=IAF.L_G_FIXOFF
	    DO WHILE (OFFSET_VEC(1).NE.I.AND.OFFSET_VEC(0).NE.0)
	      CALL LIB$MOVC3(8,HDR_BUF(J),OFFSET_VEC(0))
	      J=J+8+OFFSET_VEC(0)*4
	    ENDDO
	    OFFSET_VEC(0)=J-OFFSET_VEC(0)*4-8
	    OFFSET_VEC(1)=1
	    DO WHILE (OFFSET_VEC(1).LE.SYM_TBL_PTR.AND.
     +		      OFFSET_VEC(0)+8+ISD_BASEVA(FIXUPSEC_ISD).GT.
     +				SYM_VAL(OFFSET_VEC(1)))
	      OFFSET_VEC(1)=OFFSET_VEC(1)+1
	    ENDDO
	    CUR_VA=0
	    READ(3,REC=1) REC_BUF		! read in image header
	    CALL LIB$MOVC3(IHD$S_SIZE,REC_BUF(0),SHR_IHD)
	    CALL LIB$MOVC3(IHS$S_SIZE,REC_BUF(SHR_IHD.W_SYMDBGOFF),SHR_IHS)
	    J=SHR_IHS.W_GSTRECS
	    CUR_VBN=SHR_IHS.L_GSTVBN
	    CUR_VA=0
	    READ(3,REC=CUR_VBN) REC_BUF	! read 1st block of global symbols
	    CALL NAME_SYM_TBL(J,OFFSET_VEC(1),HDR_BUF(OFFSET_VEC(0)))
	    CLOSE(UNIT=3)
	  ENDIF
	  CALL LIB$REVERT
	ENDDO
C
C  else do V1 VMS shareable image analysis
C
      ELSE
	IAF.L_SHRIMGCNT=0
	DO I=1,ISD_NUM
	  IF((ISD(I).L_FLAGS .AND.1).NE.0)THEN	! if global section
	    IF(ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN-3:ISD(I).B_GBLNAMLEN-1)
     +			.NE.'_00'.OR.
     +	       ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN:ISD(I).B_GBLNAMLEN)
     +			.EQ.'1')THEN
	      IAF.L_SHRIMGCNT=IAF.L_SHRIMGCNT+1
	      FIX_SHL(IAF.L_SHRIMGCNT).L_BASEVA=ISD_BASEVA(I)
	      FIX_SHL(IAF.L_SHRIMGCNT).L_PERMCTX=ISD_PGEND(I)
	      FIX_SHL(IAF.L_SHRIMGCNT).L_IDENT=ISD(I).L_IDENT
	      FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN=ISD(I).B_GBLNAMLEN
	      IF(ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN-3:ISD(I).B_GBLNAMLEN-2)
     +			.EQ.'_0')THEN
		FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN=
     +			FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN-4
	      ENDIF
	      FIX_SHL(IAF.L_SHRIMGCNT).T_IMGNAM=
     +		ISD(I).T_GBLNAM(1:FIX_SHL(IAF.L_SHRIMGCNT).B_IMGNAMLEN)
	    ENDIF
	  ENDIF
	ENDDO
C
C  read in and analyze system shareable images to resolve more symbols
C    if any were linked into image
C
	DO I=1,IAF.L_SHRIMGCNT
	  CALL LIB$ESTABLISH(FIX_BUF_3)
	  J=FIX_SHL(I).B_IMGNAMLEN
	  IF(FIX_SHL(I).T_IMGNAM(1:J).EQ.'VMSRTL')THEN
	    I_FLT(1)=JISHFT(JPI$_IMAGNAME,16)+LEN(S_TMP)
	    I_FLT(2)=%LOC(S_TMP)
	    I_FLT(3)=%LOC(LN)
	    I_FLT(4)=0
	    CALL SYS$GETJPI(,,,I_FLT,,,) ! get full filespec of DISM32.EXE
	    I_FLT(1)=JISHFT(FSCN$_NAME,16)
	    I_FLT(2)=0
	    I_FLT(3)=0
	    CALL SYS$FILESCAN(S_TMP(1:LN),I_FLT,)
	    I2=I_FLT(2)-%LOC(S_TMP)
	    OPEN(UNIT=3,FILE=S_TMP(1:I2)//'VMSRTL_V3.EXE',ACCESS='DIRECT',
     +		 READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL',
     +		 RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE,
     +		 SHARED)
	  ELSE
	    OPEN(UNIT=3,FILE=FIX_SHL(I).T_IMGNAM(1:J),ACCESS='DIRECT',
     +		 READONLY,FORM='UNFORMATTED',ORGANIZATION='SEQUENTIAL',
     +		 RECL=128,RECORDTYPE='FIXED',STATUS='OLD',IOSTAT=ICODE,
     +		 DEFAULTFILE='SYS$SHARE:.EXE',SHARED)
	  ENDIF
	  IF(ICODE.NE.0)THEN
	    CALL LIB$SIGNAL(DISM__BADSHRIMG,%VAL(2),%VAL(ICODE),
     +		%DESCR(FIX_SHL(I).T_IMGNAM(1:J)))
	  ELSE
	    CUR_VA=0
	    READ(3,REC=1) REC_BUF		! read in image header
	    CALL LIB$MOVC3(IHD$S_SIZE,REC_BUF(0),SHR_IHD)
	    CALL LIB$MOVC3(IHS$S_SIZE,REC_BUF(SHR_IHD.W_SYMDBGOFF),SHR_IHS)
	    J=SHR_IHS.W_GSTRECS
	    CUR_VBN=SHR_IHS.L_GSTVBN
	    CUR_VA=0
	    READ(3,REC=CUR_VBN) REC_BUF	! read 1st block of global symbols
	    I2=IABS(FIND_P2_SYMBOL(%VAL(FIX_SHL(I).L_BASEVA)))
	    AUX_SYM_TBL(-1)=0
	    I3=I2
	    DO WHILE (I2.LE.SYM_TBL_PTR.AND.
     +		      FIX_SHL(I).L_PERMCTX .GE.SYM_VAL(I2))
	      AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)+1
	      AUX_SYM_TBL(AUX_SYM_TBL(-1))=SYM_VAL(I2)-FIX_SHL(I).L_BASEVA
	      I2=I2+1
	    ENDDO
	    CALL NAME_SYM_TBL(J,I3,AUX_SYM_TBL(-1))
	    CLOSE(UNIT=3)
	  ENDIF
	  CALL LIB$REVERT
	ENDDO
      ENDIF
C
C  scan for transfer vectors (shareable images) and fix up symbol names for
C	destinations of vectors
C
      CALL LIB$ESTABLISH(FIX_BUFR_OVRFL)
      I=1
      DO WHILE (I.LE.SYM_TBL_PTR)
	IF((SYM_TYP(I).AND.SYM_TRANSFER).NE.0)THEN
	  IF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN
	    ADDR=SYM_VAL(I)+2
	  ELSE
	    ADDR=SYM_VAL(I)
	  ENDIF
	  IF(ADDR.GE.ISD_BASEVA(1).AND.
     +	     ADDR.LE.ISD_PGEND(1))THEN
	    CALL COPY_BYTE(ADDR,DISPL_BYT)	! get opcode
	    IF(DISPL_BYT.EQ.'11'X)THEN		! BRB instruction
	      CALL COPY_BYTE(ADDR+1,DISPL_BYT)
	      I2=ADDR+DISPL_BYT+2
	      
	    ELSEIF(DISPL_BYT.EQ.'31'X)THEN	! BRW instruction
	      CALL COPY_WORD(ADDR+1,DISPL_WRD)
	      I2=ADDR+DISPL_WRD+3
	      
	    ELSEIF(DISPL_BYT.EQ.'17'X)THEN	! JMP instruction
	      CALL COPY_BYTE(ADDR+1,DISPL_BYT)
	      IF((DISPL_BYT.AND.'F0'X).GE.'90'X.AND.
     +	         (DISPL_BYT.AND.'0F'X).EQ.'0F'X)THEN	! absolute or PC relative
	        
	      ENDIF
	    ENDIF
	  ENDIF
	ENDIF
	I=I+1
      ENDDO
      CALL LIB$REVERT
C
C  scan for RMS data blocks and procedure entry points and mark immediately
C	following symbols within the block as non-definable; also record any
C	special extended data types for special macro expansion
C
      CALL LIB$ESTABLISH(FIX_BUFR_OVRFL)
      I=1
      DO WHILE (I.LE.SYM_TBL_PTR)
	IF((SYM_TYP(I).AND.SYM_D_RMS).NE.0)THEN
	  J=I+1
	  I2=0
	  CALL COPY_BYTE(SYM_VAL(I)+1,I2)
	  DO WHILE (SYM_VAL(J).LT.SYM_VAL(I)+I2.AND.
     +		    J.LE.SYM_TBL_PTR)
	    SYM_TYP(J)=SYM_TYP(J).OR.SYM_NOTDEF
	    SYM_NAM(J)=' '
	    J=J+1
	  ENDDO
	  I=J
	ELSEIF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN
	  J=I+1
	  DO WHILE (SYM_VAL(J).LE.SYM_VAL(I)+2.AND.
     +		    J.LE.SYM_TBL_PTR)
	    SYM_TYP(J)=SYM_TYP(J).OR.SYM_NOTDEF
	    SYM_NAM(J)=' '
	    J=J+1
	  ENDDO
	  I=J
	ELSEIF((SYM_TYP(I).AND.SYM_D_EXTENDED).NE.0)THEN
	  IF(SYM_EXT_ATTR(I).NE.SYM_T_KEYWRDTBL.AND.
     +	     SYM_EXT_ATTR(I).NE.SYM_T_STATE)THEN
	    SYM_NEED_MACRO(SYM_EXT_ATTR(I))=.TRUE.
	  ENDIF
	  I=I+1
	ELSE
	  I=I+1
	ENDIF
      ENDDO
C
C  find if any symbol definitions unspecified that might be address-referenced
C    condition code values and make up symbol names for them
C
      IF(FIXUPSEC_ISD.NE.0.AND.
     +	 MSG_NUMFAC.NE.0)THEN
	K=IABS(FIND_P2_SYMBOL(%VAL(ISD_PGEND(FIXUPSEC_ISD)+1)))
	IF(K.NE.0.AND.
     +	   (SYM_VAL(K).AND.'E0000000'X).EQ.0.AND.
     +	   (SYM_VAL(K).AND.'7'X).LE.4)THEN
	  I=1
	  I2=JISHFT(IAND(SYM_VAL(K),'0FFF0000'X),-16)
	  DO WHILE (I.LE.MSG_NUMFAC.AND.
     +		    I2.NE.MSG_FACDESCR(4,I))
	    I=I+1
	  ENDDO
	  
	ENDIF
      ENDIF
C
C  scan through the symbol table and make up symbol names for all
C    unnamed entries
C
      DO I=1,SYM_TBL_PTR
	IF((SYM_TYP(I).AND.SYM_NOTDEF).EQ.0) J=I
	IF(SYM_NAM(I).EQ.' ')THEN
	  CALL OTS$CVT_L_TZ(SYM_VAL(I),S_TMP(1:8),%VAL(8))
	  IF((SYM_TYP(I).AND.SYM_NOTDEF).NE.0.AND.
     +	     (SYM_TYP(I).AND.SYM_D_EXTENDED).EQ.0)THEN
	    CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN)
	    CALL SYS$FAO('!AD+!UL',,SYM_NAM(I),%VAL(LN),%REF(SYM_NAM(J)),
     +					%VAL(SYM_VAL(I)-SYM_VAL(J)))
	  ELSEIF((SYM_TYP(I).AND.SYM_PROC).NE.0)THEN
	    SYM_NAM(I)='P_'//S_TMP(1:8)
	  ELSEIF((SYM_TYP(I).AND.SYM_SUBR).NE.0)THEN
	    SYM_NAM(I)='S_'//S_TMP(1:8)
	  ELSEIF((SYM_TYP(I).AND.SYM_JMPE).NE.0)THEN
	    SYM_NAM(I)='LB_'//S_TMP(1:8)
	  ELSE	! data type only
	    IF((SYM_TYP(I).AND.SYM_BASEADR).NE.0)THEN
	      SYM_NAM(I)='BASE_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_EXTENDED).NE.0)THEN
	      CALL EXTENDED_DATA_SYMNAM(I,S_TMP(1:8))
	    ELSEIF((SYM_TYP(I).AND.SYM_D_RMS).NE.0)THEN
	      SYM_NAM(I)='RMS_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_FORMAT).NE.0)THEN
	      SYM_NAM(I)='FORMAT_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_HFL).NE.0)THEN
	      SYM_NAM(I)='H_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_GFL).NE.0)THEN
	      SYM_NAM(I)='G_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_DFL).NE.0)THEN
	      SYM_NAM(I)='D_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_FLT).NE.0)THEN
	      SYM_NAM(I)='F_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_OCT).NE.0)THEN
	      SYM_NAM(I)='O_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_QUD).NE.0)THEN
	      SYM_NAM(I)='Q_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_CHR).NE.0)THEN
	      SYM_NAM(I)='STR_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_PDS).NE.0)THEN
	      SYM_NAM(I)='PDEC_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_LSN).NE.0)THEN
	      SYM_NAM(I)='LSTR_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_TNS).NE.0)THEN
	      SYM_NAM(I)='TNSTR_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_WRD).NE.0)THEN
	      SYM_NAM(I)='W_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_LNG).NE.0)THEN
	      SYM_NAM(I)='L_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_TBL).NE.0)THEN
	      SYM_NAM(I)='TBL_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_PTN).NE.0)THEN
	      SYM_NAM(I)='PTTN_'//S_TMP(1:8)
	    ELSEIF((SYM_TYP(I).AND.SYM_D_BYT).NE.0)THEN
	      SYM_NAM(I)='B_'//S_TMP(1:8)
	    ENDIF
	  ENDIF
	ENDIF
      ENDDO
C
C  report on transfer addresses (if any exist)
C
      IF(IHA.L_TFRADR(1).NE.0)THEN
	WRITE(2,9150) 
 9150	FORMAT(';'/
     +	       ';   transfer addresses:')
	DO I=1,3
	  IF(IHA.L_TFRADR(I).NE.0)THEN
	    K=FIND_P2_SYMBOL(%VAL(IHA.L_TFRADR(I)))
	    IF(K.GT.0)THEN
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,9151) IHA.L_TFRADR(I), SYM_NAM(K)(1:LN)
 9151	      FORMAT(';       ',Z8.8,X,A)
	    ELSE
	      WRITE(2,9152) IHA.L_TFRADR(I)
 9152	      FORMAT(';       ',Z8.8)
	    ENDIF
	  ENDIF
	ENDDO
      ENDIF
C
C  add special macro definitions if needed
C
      DO I=1,20
	IF(SYM_NEED_MACRO(I))THEN
	  WRITE(2,9153) TAB, SPECIAL_MACRO(I)
 9153	  FORMAT(A1,A)
	ENDIF
      ENDDO
C
C  begin pass 2 disassembly
C
      CALL LIB$PUT_OUTPUT('Beginning pass 2...')
      CALL LIB$ESTABLISH(FIX_BUFR_OVRFL)
      MOD_PTR=1		! set up module table indexing
      DO I=1,ISD_NUM
	CALL STR$TRIM(ISD_NAM(I),ISD_NAM(I),LN2)
	CALL SYS$FAO('Beginning ISD !AS (^X!XL to ^X!XL)...',LN,OUT_FIL,
     +		     ISD_NAM(I)(1:LN2),
     +		     %VAL(ISD_BASEVA(I)),%VAL(ISD_PGEND(I)))
	CALL LIB$PUT_OUTPUT(OUT_FIL(1:LN))
	I3=JISHFT(ISD(I).L_FLAGS, -24)
	IF(I3.EQ.253.OR.
     +	   I3.EQ.-3)GOTO 5000 ! skip stack section
	WRITE(2,9002)
	WRITE(2,9200)form_feed,TAB,TAB,ISD_NAM(I)(1:LN2)
 9200	FORMAT(A1/
     +	       A1,'.SBTTL',A1,'Image section ',A)
	WRITE(2,9002)
	LN3=JISHFT(ISD(I).L_VPNPFC,-24)
	I2=IAND(ISD(I).L_FLAGS,'00FFFFFF'X)
	WRITE(2,9210) I, ISD_BASEVA(I), ISD_PGEND(I), ISD(I).W_PAGCNT,
     +		      LN3, I2, ISD(I).L_VBN, C_ISDTYP(I3)
 9210	FORMAT(';  Image section',I3,': start ^X',Z8.8,', end ^X',Z8.8,
     +				', contains',I6,' pages'/
     +	       ';      PFC =',I3,', linker flags ^X',Z6.6,
     +				', base VBN =',I5,', type=',A)
	WRITE(2,9002)
C
C  select method of disassembly, depending on I-sect type
C
	IF((ISD(I).L_FLAGS .AND.1).NE.0)GOTO 4000	! process shareable section
	IF((ISD(I).L_FLAGS .AND.'400'X).NE.0)GOTO 4500	! process fixup vector
	IF((ISD(I).L_FLAGS .AND.'20000'X).NE.0)GOTO 4800! process message section
C
C  do each program section from an image section
C
	S_TMP=CHAR(9)//'.PSECT'//CHAR(9)//ISD_NAM(I)(1:LN2)//
     +				',USR,CON,REL,NOVEC,RD,'
	LN=LN2+31
	IF((ISD(I).L_FLAGS .AND.'8'X).NE.0)THEN		! ISD$M_WRT
	  S_TMP(LN:)='WRT,'
	  LN=LN+4
	ELSE
	  S_TMP(LN:)='NOWRT,'
	  LN=LN+6
	ENDIF
	IF(ISD(I).W_SIZE .LT.0)THEN
	  S_TMP(LN:)='EXE,'
	  LN=LN+4
	ELSE
	  S_TMP(LN:)='NOEXE,'
	  LN=LN+6
	ENDIF
	IF((ISD(I).L_FLAGS .AND.'200'X).EQ.0)THEN	! ISD$M_BASED
	  S_TMP(LN:)='PIC,'	! private or shareable PIC I-sect
	  LN=LN+4
	ELSE
	  S_TMP(LN:)='NOPIC,'
	  LN=LN+6
	ENDIF
	IF((ISD(I).L_FLAGS .AND.1).NE.0)THEN		! ISD$M_GBL
	  S_TMP(LN:)='GBL,'
	ELSE
	  S_TMP(LN:)='LCL,'
	ENDIF
	LN=LN+4
	IF((ISD(I).L_FLAGS .AND.'102'X).NE.0)THEN ! ISD$M_CRF, ISD$M_COPYALWAYS
	  S_TMP(LN:)='NOSHR,'
	  LN=LN+6
	ELSE
	  S_TMP(LN:)='SHR,'
	  LN=LN+4
	ENDIF
	S_TMP(LN:)='LONG'
	LN=LN+3
	WRITE(2,'(A)') S_TMP(1:LN)
	WRITE(2,9002)
C
C  set up to start 'P-section' by getting base address, base VBN (if any),
C    reading VB, and initializing to data (as opposed to code) mode
C
	CUR_VA=ISD_BASEVA(I)
	ADDR=ISD_BASEVA(I)
	CUR_VBN=ISD(I).L_VBN
 2000	IF(CUR_VBN.NE.0)THEN	! this is normal processing entry for vector
	  READ(1,REC=CUR_VBN) REC_BUF	! I-sects as well
	ELSE
	  CALL LIB$MOVC5(0,0,0,512,REC_BUF)
	ENDIF
	OK=.FALSE.	! set to data mode
	J=0
	IF((ISD(I).L_FLAGS .AND.4).NE.0)GOTO 3000	! process demand zero section
	DO WHILE (ADDR.LE.ISD_PGEND(I))
C
C  find the module in module table equal to current address
C
	  IF(MOD_PTR.LE.MOD_TBL_PTR)THEN
	    IF(MOD_START(MOD_PTR).GT.ADDR)THEN
	      CONTINUE
	    ELSEIF(MOD_START(MOD_PTR).LT.ADDR)THEN
	      MOD_PTR=MOD_PTR+1
	    ELSE
	      CALL STR$TRIM(MOD_NAM(I2),MOD_NAM(I2),LN)
	      WRITE(2,9201) MOD_NAM(I2)(1:LN),
     +			    LANGUAGE_NAME(MOD_LNG(I2)),
     +			    MOD_VERMAJ(I2), MOD_VERMIN(I2)
 9201	      FORMAT(';'/
     +		     ';  Module ',A,', compiled by ',A,' V',I2.2,'.',I2.2)
	    ENDIF
	  ENDIF
C
C  find the first symbol in symbol table equal to or greater than current
C    address
C
	  CURR_ADR=ADDR
	  K=IABS(FIND_P2_SYMBOL(%VAL(ADDR)))
	  J=K
	  DO WHILE (((SYM_TYP(J).AND.SYM_NOTDEF).NE.0.AND.
     +		     (SYM_TYP(J).AND.SYM_D_EXTENDED).EQ.0).AND.
     +		    J.LE.SYM_TBL_PTR)
	    J=J+1
	  ENDDO
	  I2=MIN(SYM_VAL(J)-ADDR,MAX(ISD_PGEND(I)-ADDR,0))
	  IF(SYM_VAL(J).EQ.ADDR)THEN
	    CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN)
	    IF((SYM_TYP(J).AND.SYM_PROC).NE.0)THEN
		LLV_CODEMODE=.TRUE.	! switch to code mode
		WRITE(2,9002)
		S_TMP=CHAR(9)//'.ENTRY'//CHAR(9)//SYM_NAM(J)(1:LN)//
     +			',^M<'
		LN=LN+13
		ICODE=0
		CALL COPY_WORD(ADDR,ICODE)	! get entry mask word
		ADDR=ADDR+2
		CURR_ADR=ADDR
		CALL MAKE_MASK(S_TMP(LN:),ICODE,LN2)
		LN=LN+LN2-1
		WRITE(2,'(A)') S_TMP(1:LN)
	    ELSEIF((SYM_TYP(J).AND.SYM_M_CODE).NE.0)THEN
		LLV_CODEMODE=.TRUE.	! switch to code mode
		WRITE(2,'(A,'':'')') SYM_NAM(J)(1:LN)
	    ELSE
!!???		LLV_CODEMODE=.FALSE.	! switch to data mode
		IF((SYM_TYP(J).AND.SYM_NOTDEF).EQ.0)THEN
		  WRITE(2,'(A,'':'')') SYM_NAM(J)(1:LN)
		ENDIF
	    ENDIF
	    I2=MIN(SYM_VAL(J+1),ISD_PGEND(I))-SYM_VAL(J)
	  ELSE
	    IF(SYM_VAL(K).EQ.ADDR)THEN
	      J=K
	    ELSE
	      J=K-1
	    ENDIF
	  ENDIF
C
C  disassemble object into either appropriate type data or executable
C    code, depending on mode
C
	  IF(LLV_CODEMODE)THEN
	    K=DISM_INSTR(ADDR,1)	! disassemble instruction
	    IF(K.EQ.0)THEN
	      LLV_CODEMODE=.FALSE.		! end of code section, switch to data
	    ELSEIF(K.EQ.%LOC(DISM__INVOPCODE))THEN
	      WRITE(2,9205)TAB,TAB,TAB,TAB
 9205	      FORMAT(A1,'.WARN',A1,'0',2A1,'; Undefined opcode')
	    ENDIF
	  ELSE
C
C  unscramble data into data areas, according to last symbol type
C
	    K=25
	    I8='08000000'X
 2009	    DO WHILE (((SYM_TYP(J).AND.I8).EQ.0.OR.
     +		       (SYM_VAL(J).NE.ADDR.AND..NOT.DTYP_CONTINUE(K))).AND.
     +		      I8.GE.'8'X)
	      K=K-1
	      I8=I8/2
	    ENDDO
	    IF(DTYP_SIZE(K).GT.I2)K=1	! in case of alignment problems
	    GOTO (2010,2020,2030,2040,2050,2060,2070,2080,2090,2100,
     +		2110,2120,2130,2140,2150,
     +		2030,		! hole-filling
     +		2190,2200,
     +		2210,2220,2230,2240,2250,2260,2270),K	! vector to appropriate routine
C
C  handler for type longword (also default handler)
C
 2030	    CALL COPY_LONG(ADDR,I2)
	    ADDR=ADDR+4
	    IF(I2.NE.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(I2))
	      IF(K.GT.0)THEN
		CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN3)
		WRITE(2,9230)TAB,TAB,SYM_NAM(K)(1:LN3)
 9230		FORMAT(A1,'.ADDRESS',A1,A)
		GOTO 2900
	      ENDIF
	    ENDIF
	    S_TMP=CHAR(9)//'.LONG'//CHAR(9)//'^X'
	    CALL OTS$CVT_L_TZ(I2,S_TMP(10:17),%VAL(8))
	    CALL WRITE_OUTPUT_TEXT(S_TMP(1:17))
	    GOTO 2900
C
C  handler for type byte
C
 2010	    CALL COPY_BYTE(ADDR,I2)
	    ADDR=ADDR+1
	    S_TMP=CHAR(9)//'.BYTE'//CHAR(9)//'^X'
	    CALL OTS$CVT_L_TZ(I2,S_TMP(10:11),%VAL(2),%VAL(1))
	    CALL WRITE_OUTPUT_TEXT(S_TMP(1:11))
	    GOTO 2900
C
C  handler for type word
C
 2020	    I2=0
	    CALL COPY_WORD(ADDR,I2)
	    ADDR=ADDR+2
	    S_TMP=CHAR(9)//'.WORD'//CHAR(9)//'^X'
	    CALL OTS$CVT_L_TZ(I2,S_TMP(10:13),%VAL(4),%VAL(2))
	    CALL WRITE_OUTPUT_TEXT(S_TMP(1:13))
	    GOTO 2900
C
C  handler for type quadword
C
 2040	    CALL COPY_LONG(ADDR,I2)
	    ADDR=ADDR+4
	    CALL COPY_LONG(ADDR,I3)
	    ADDR=ADDR+4
	    K=FIND_P2_SYMBOL(%VAL(I3))
	    IF(K.GT.0)THEN
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN3)
	      S_TMP=CHAR(9)//'.LONG'//CHAR(9)//'^X'
	      CALL OTS$CVT_L_TZ(I2,S_TMP(10:17),%VAL(8))
	      CALL WRITE_OUTPUT_TEXT(S_TMP(1:17))
	      WRITE(2,9230)TAB,TAB,SYM_NAM(K)(1:LN3)
	      GOTO 2900
	    ENDIF
	    IF(ADDR.EQ.I3.AND.
     +	       (I2.AND.'FFFF0000'X).EQ.0)THEN
	      S_TMP=CHAR(9)//'.LONG'//CHAR(9)//'^X'
	      CALL OTS$CVT_L_TZ(I2,S_TMP(10:17),%VAL(8))
	      CALL WRITE_OUTPUT_TEXT(S_TMP(1:17))
	      WRITE(2,9240)TAB,TAB
 9240	      FORMAT(A1,'.ADDRESS',A1,'.+4')
	      GOTO 2900
	    ENDIF
	    K=1
	    DO WHILE (K.LE.SYM_TBL_PTR.AND.
     +		      SYM_VAL(K).LT.ADDR)
	      K=K+1
	    ENDDO
	    I8=I2.AND.'FFFF'X
	    IF(SYM_VAL(K)-ADDR.GE.I8.AND.
     +	       I3.EQ.ADDR.AND.
     +	       (JISHFT(I2.AND.'00FF0000'X,-16).EQ.14.OR.
     +		JISHFT(I2.AND.'00FF0000'X,-16).EQ.16.OR.
     +		JISHFT(I2.AND.'00FF0000'X,-16).EQ.18).AND.
     +	       JISHFT(I2.AND.'FF000000'X,-24).EQ.1)THEN
	      DO K=1,I8
		CALL COPY_BYTE(ADDR,%REF(CMD_LIN(K:K)))
		ADDR=ADDR+1
	      ENDDO
	      K=STR$FIND_FIRST_NOT_IN_SET(STR_DELIM,
     +			CMD_LIN(1:I8))
	      S_TMP=CHAR(9)//'.ASCID'//CHAR(9)//STR_DELIM(K:K)//
     +			CMD_LIN(1:I8)//STR_DELIM(K:K)
	      LN=I8+10
	      GOTO 2899
	    ENDIF
	    S_TMP=CHAR(9)//'.QUAD'//CHAR(9)//'^X'
	    CALL OTS$CVT_L_TZ(I3,S_TMP(10:17),%VAL(8))
	    CALL OTS$CVT_L_TZ(I2,S_TMP(18:25),%VAL(8))
	    CALL WRITE_OUTPUT_TEXT(S_TMP(1:25))
	    GOTO 2900
C
C  handler for type F_floating
C
 2050	    CALL COPY_LONG(ADDR,X_FLT)
	    ADDR=ADDR+4
	    ICODE=CONVERT_F_FLOAT(X_FLT,S_TMP(1:14),LN)
	    IF(.NOT.ICODE) LN=0
	    WRITE(2,9250)TAB,TAB,I_FLT(1),TAB,S_TMP(1:LN)
 9250	    FORMAT(A1,'.LONG',A1,'^X',Z8.8,A1,'; F_float ',A)
	    GOTO 2900
C
C  handler for D_floating type
C
 2060	    CALL COPY_LONG(ADDR,I_FLT(1))
	    ADDR=ADDR+4
	    CALL COPY_LONG(ADDR,I_FLT(2))
	    ADDR=ADDR+4
	    ICODE=CONVERT_D_FLOAT(X_DFL,S_TMP(1:24),LN)
	    IF(.NOT.ICODE) LN=0
	    WRITE(2,9260)TAB,TAB,I_FLT(1),I_FLT(2),TAB,S_TMP(1:LN)
 9260	    FORMAT(A1,'.LONG',A1,'^X',Z8.8,',^X',Z8.8,A1,'; D_float ',A)
	    GOTO 2900
C
C  handler for G_floating type
C
 2070	    CALL COPY_LONG(ADDR,I_FLT(1))
	    ADDR=ADDR+4
	    CALL COPY_LONG(ADDR,I_FLT(2))
	    ADDR=ADDR+4
	    ICODE=CONVERT_G_FLOAT(X_DFL,S_TMP(1:24),LN)
	    IF(.NOT.ICODE) LN=0
	    WRITE(2,9270)TAB,TAB,I_FLT(1),I_FLT(2),TAB,S_TMP(1:LN)
 9270	    FORMAT(A1,'.LONG',A1,'^X',Z8.8,',^X',Z8.8,A1,'; G_float ',A)
	    GOTO 2900
C
C  handler for H_floating type
C
 2080	    DO I3=1,4
	      CALL COPY_LONG(ADDR,I_FLT(I3))
	      ADDR=ADDR+4
	    ENDDO
	    ICODE=CONVERT_H_FLOAT(X_HFL,S_TMP(1:42),LN)
	    IF(.NOT.ICODE) LN=0
	    WRITE(2,9280)TAB,TAB,I_FLT,TAB,S_TMP(1:LN)
 9280	    FORMAT(A1,'.LONG',A1,'^X',Z8.8,3(',^X',Z8.8),A1,
     +				'; H_float ',A)
	    GOTO 2900
C
C  handler for character string type
C
 2090	    S_TMP=CHAR(9)//'.ASCII'//CHAR(9)//'"'
	    LN=10
	    LN2=0
 2092	    IF(LN2.NE.0)THEN
	      I3=MIN0(LN2,64)
	    ELSE
	      I3=MIN0(I2,64)
	    ENDIF
	    I2=0
	    DO K=1,I3
	      CALL COPY_BYTE(ADDR,I2)
	      ADDR=ADDR+1
	      IF(I2.EQ.ICHAR('"'))THEN
		S_TMP(LN:LN+4)='"/"/"'
		LN=LN+5
	      ELSEIF(I2.LT.127.AND.I2.GE.32)THEN
		S_TMP(LN:LN)=CHAR(I2)
		LN=LN+1
	      ELSE
		ADDR=ADDR-1
		IF(K.EQ.1)GOTO 2010
		GOTO 2095
	      ENDIF
	    ENDDO
 2095	    S_TMP(LN:LN)='"'
	    GOTO 2899
C
C  handler for packed decimal string type
C
 2100	    S_TMP=CHAR(9)//'.PACKED'//CHAR(9)//' '
	    LN=10
	    DO K=1,16
	      CALL COPY_BYTE(ADDR,I2)
	      ADDR=ADDR+1
	      S_TMP(LN+1:LN+2)=CHAR((I2/16)+48)//CHAR((I2.AND.'F'X)+48)
	      LN=LN+2
	      IF(S_TMP(LN:LN).GT.'9')THEN
		I2=I2.AND.'F'X
		LN=LN-1
		IF(I2.EQ.11.OR.I2.EQ.13)THEN
		  S_TMP(10:10)='-'
		ELSE
		  S_TMP(10:10)='+'
		ENDIF
		GOTO 2105
	      ENDIF
	    ENDDO
 2105	    GOTO 2899
C
C  handler for leading separate numeric string type
C
 2110	    S_TMP=CHAR(9)//'.ASCII'//CHAR(9)//'/'
	    LN=9
	    CALL COPY_BYTE(ADDR,%REF(S_TMP(LN+1:LN+1)))
	    IF(S_TMP(LN+1:LN+1).NE.'+'.AND.
     +	       S_TMP(LN+1:LN+1).NE.' '.AND.
     +	       S_TMP(LN+1:LN+1).NE.'-'.AND.
     +	       (S_TMP(LN+1:LN+1).LT.'0'.OR.S_TMP(LN+1:LN+1).GT.'9'))THEN
	      GOTO 2010		! treat as byte
	    ELSE
	      LN=LN+1
	      ADDR=ADDR+1
	      K=IABS(FIND_P2_SYMBOL(%VAL(ADDR)))
	      I3=MIN(SYM_VAL(K),ISD_PGEND(I))
	      CALL COPY_BYTE(ADDR,%REF(S_TMP(LN+1:LN+1)))
	      DO WHILE (ADDR.LT.I3.AND.
     +			LN.LE.70.AND.
     +			S_TMP(LN+1:LN+1).GE.'0'.AND.
     +			S_TMP(LN+1:LN+1).LE.'9')
		LN=LN+1
		ADDR=ADDR+1
		CALL COPY_BYTE(ADDR,%REF(S_TMP(LN+1:LN+1)))
	      ENDDO
	      LN=LN+1
	      S_TMP(LN:LN)='/'
	      GOTO 2899
	    ENDIF
	    GOTO 2900
C
C  handler for trailing numeric string type
C
 2120	    CALL WRITE_OUTPUT_TEXT(CHAR(9)//
     +			'; trailing numeric string type')
	    GOTO 2010
C
C  handler for table types
C
 2130	    CALL WRITE_OUTPUT_TEXT(CHAR(9)//'; table type')
	    K=12
	    I8=SYM_D_TBL/2
	    GOTO 2009
C
C  handler for edit pattern string type
C
 2140	    I2=-1
	    DO WHILE (I2.NE.0)
	      LN=1
	      S_TMP=CHAR(9)
	      CALL COPY_BYTE(ADDR,I2)
	      ADDR=ADDR+1
	      I3=1
	      DO WHILE (EDIT_MASK(I3).NE.0.AND.I2.NE.0)
		K=I2.AND.EDIT_MASK(I3)
		IF(K.EQ.EDIT_OPC(I3))THEN
		  CALL STR$TRIM(EDIT_NAM(I3),EDIT_NAM(I3),LN2)
		  S_TMP(LN+1:LN+LN2)=EDIT_NAM(I3)(1:LN2)
		  LN=LN+LN2
		  IF(K.EQ.0)THEN
		    I2=0
		  ELSE
		    GOTO (2145,2141,2142,2143), EDIT_ARG(I3)+1
 2141		      CALL SYS$FAO('!_!UB',LN2,S_TMP(LN+1:),
     +				%VAL(I2.AND.'F'X))
		      LN=LN+LN2
		      GOTO 2145
 2142		      CALL COPY_BYTE(ADDR,I3)
		      ADDR=ADDR+1
		      CALL SYS$FAO('!_!UB',LN2,S_TMP(LN+1:),%VAL(I3))
		      LN=LN+LN2
		      GOTO 2145
 2143		      CALL COPY_BYTE(ADDR,I3)
		      ADDR=ADDR+1
		      IF(I3.GE.'20'X.AND.I3.LE.'7E'X.AND.
     +			 I3.NE.'22'X)THEN
			CALL SYS$FAO('!_"!AD"',LN2,S_TMP(LN+1:),%VAL(1),I3)
			LN=LN+LN2
		      ELSE
			S_TMP(LN+1:)=CHAR(9)//'^X'
			CALL OTS$CVT_L_TZ(I2,S_TMP(LN+4:LN+5),%VAL(8))
			LN=LN+5
		      ENDIF
		      GOTO 2145
		  ENDIF
		  GOTO 2145
		ELSE
		  I3=I3+1
		ENDIF
	      ENDDO
 2145	      CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	    ENDDO
	    GOTO 2900
C
C  handler for octaword type
C
 2150	    DO I3=1,4
	      CALL COPY_LONG(ADDR,I_FLT(I3))
	      ADDR=ADDR+4
	    ENDDO
	    S_TMP=CHAR(9)//'.OCTA'//CHAR(9)//'^X'
	    CALL OTS$CVT_L_TZ(I_FLT(4),S_TMP(10:17),%VAL(8))
	    CALL OTS$CVT_L_TZ(I_FLT(3),S_TMP(18:25),%VAL(8))
	    CALL OTS$CVT_L_TZ(I_FLT(2),S_TMP(26:33),%VAL(8))
	    CALL OTS$CVT_L_TZ(I_FLT(1),S_TMP(34:41),%VAL(8))
	    CALL WRITE_OUTPUT_TEXT(S_TMP(1:41))
	    GOTO 2900
C
C  handler for extended data structures
C
 2190	    CALL EXTENDED_DATA_PASS2(ADDR,J)
	    GOTO 2900
C
C  handler for transfer vectors
C
 2200	    CALL LIB$SIGNAL(DISM__CORDTSTRUC)
	    GOTO 2900
C
C  handler for RMS data structures
C
 2210	    I2=0
	    I3=0
	    CALL COPY_BYTE(ADDR,I2)	! xxx$B_BID
	    CALL COPY_BYTE(ADDR+1,I3)	! xxx$B_BLN
	    IF(I2.EQ.'1'X)THEN		! RAB$C_BID
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$RAB'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+60,I8)	! RAB$L_FAB
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FAB='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FAB=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      CALL COPY_LONG(ADDR+48,I8)	! RAB$L_KBF
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KBF='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KBF=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+53,I8)	! RAB$B_KRF
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KRF=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+52,I8)	! RAB$B_KSZ
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'KSZ=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+54,I8)	! RAB$B_MBF
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'MBF=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+55,I8)	! RAB$B_MBC
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'MBC=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+30,I8)	! RAB$B_RAC
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RAC=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      CALL COPY_LONG(ADDR+40,I8)	! RAB$L_RBF
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RBF='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RBF=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      CALL COPY_LONG(ADDR+44,I8)	! RAB$L_RHB
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RHB='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RHB=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      CALL COPY_LONG(ADDR+8,I8)	! RAB$L_ROP
	      IF(I8.NE.0) THEN
		S_TMP=CHAR(9)//CHAR(9)//'ROP=<'
		LN=7
		DO I9=0,31
		  IF((I8.AND.JISHFT(1,I9)).NE.0)THEN
		    S_TMP(LN+1:)=C_ROP_CODES(I9)//','
		    LN=LN+4
		  ENDIF
		ENDDO
		S_TMP(LN:LN)='>,-'
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2))
	      ENDIF
	      I8=0
	      CALL COPY_WORD(ADDR+34,I8)	! RAB$W_RSZ
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:4),%VAL(4))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSZ=^X'//
     +						S_TMP(1:4)//',-')
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+31,I8)	! RAB$B_TMO
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'TMO=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      CALL COPY_LONG(ADDR+36,I8)	! RAB$L_UBF
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'UBF='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'UBF=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      I8=0
	      CALL COPY_WORD(ADDR+32,I8)	! RAB$W_USZ
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:4),%VAL(4))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'USZ=^X'//
     +						S_TMP(1:4)//',-')
	      ENDIF
	      CALL COPY_LONG(ADDR+64,I8)	! RAB$L_XAB
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      CALL COPY_LONG(ADDR+24,I8)	! RAB$L_CTX
	      K=FIND_P2_SYMBOL(%VAL(I8))
	      IF(K.GT.0)THEN
		CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX='//
     +						SYM_NAM(K)(1:LN))
	      ELSE
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX=^X'//
     +						S_TMP(1:8))
	      ENDIF
	    ELSEIF(I2.EQ.'2'X)THEN	! NAM$C_BID
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$NAM'//CHAR(9)//'-')
	      I8=0
	      CALL COPY_BYTE(ADDR+2,I8)		! NAM$B_RSS
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSS=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      CALL COPY_LONG(ADDR+4,I8)		! NAM$L_RSA
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSA='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RSA=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      CALL COPY_LONG(ADDR+16,I8)	! NAM$L_RLF
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RLF='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RLF=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+10,I8)	! NAM$B_ESS
	      IF(I8.NE.0) THEN
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ESS=^X'//
     +						S_TMP(1:2)//',-')
	      ENDIF
	      CALL COPY_LONG(ADDR+12,I8)	! NAM$L_ESA
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ESA='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ESA=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+8,I8)		! NAM$B_NOP
	      CALL OTS$CVT_L_TZ(I8,S_TMP(1:2),%VAL(2))
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NOP=^X'//
     +						S_TMP(1:2))
	    ELSEIF(I2.EQ.'3'X)THEN	! FAB$C_BID
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$FAB'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+16,I8)	! FAB$L_ALQ
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_ALQ=!UL,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+62,I8)	! FAB$B_BKS
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_BKS=!UB,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      I8=0
	      CALL COPY_WORD(ADDR+20,I8)	! FAB$W_DEQ
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_DEQ=!UW,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      CALL COPY_LONG(ADDR+48,I8)	! FAB$L_DNA
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'DNA='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'DNA=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+53,I8)	! FAB$B_DNS
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_DNS=!UB,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+22,I8)	! FAB$B_FAC
	      IF(I8.NE.0) THEN
		S_TMP=CHAR(9)//CHAR(9)//'FAC=<'
		LN=7
		DO I9=0,7
		  IF((I8.AND.JISHFT(1,I9)).NE.0)THEN
		    S_TMP(LN+1:)=C_FAB_FAC_CODES(I9)//','
		    LN=LN+4
		  ENDIF
		ENDDO
		S_TMP(LN:LN)='>,-'
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2))
	      ENDIF
	      CALL COPY_LONG(ADDR+44,I8)	! FAB$L_FNA
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FNA='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'FNA=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+52,I8)	! FAB$B_FNS
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_FNS=!UB,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      CALL COPY_LONG(ADDR+4,I8)		! FAB$L_FOP
	      IF(I8.NE.0) THEN
		S_TMP=CHAR(9)//CHAR(9)//'FOP=<'
		LN=7
		DO I9=0,30
		  IF((I8.AND.JISHFT(1,I9)).NE.0)THEN
		    S_TMP(LN+1:)=C_FAB_FOP_CODES(I9)//','
		    LN=LN+4
		  ENDIF
		ENDDO
		S_TMP(LN:LN)='>,-'
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2))
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+63,I8)	! FAB$B_FSZ
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_FSZ=!UB,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      I8=0
	      CALL COPY_WORD(ADDR+72,I8)	! FAB$W_GBC
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_GBC=!UW,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      CALL COPY_LONG(ADDR+56,I8)	! FAB$L_MRN
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_MRN=!UL,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      I8=0
	      CALL COPY_WORD(ADDR+54,I8)	! FAB$W_MRS
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_MRS=!UW,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      CALL COPY_LONG(ADDR+40,I8)	! FAB$L_NAM
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NAM='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NAM=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+29,I8)	! FAB$B_ORG
	      IF(I8.EQ.0) THEN
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=SEQ,-')
	      ELSEIF(I8.EQ.16) THEN
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=REL,-')
	      ELSEIF(I8.EQ.32) THEN
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=IDX,-')
	      ELSEIF(I8.EQ.48) THEN
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'ORG=HSH,-')
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+30,I8)	! FAB$B_RAT
	      IF(I8.NE.0) THEN
		S_TMP=CHAR(9)//CHAR(9)//'RAT=<'
		LN=7
		DO I9=0,3
		  IF((I8.AND.JISHFT(1,I9)).NE.0)THEN
		    S_TMP(LN+1:)=C_FAB_RAT_CODES(I9)//','
		    LN=LN+4
		  ENDIF
		ENDDO
		S_TMP(LN:LN)='>,-'
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2))
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+31,I8)	! FAB$B_RFM
	      IF(I8.GT.0.AND.I8.LE.6)THEN
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'RFM='//
     +					C_FAB_RFM_CODES(I8)//',-')
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+28,I8)	! FAB$B_RTV
	      IF(I8.NE.0) THEN
		CALL SYS$FAO('!_!_RTV=!UB,-',LN,S_TMP,%VAL(I8))
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	      ENDIF
	      I8=0
	      CALL COPY_BYTE(ADDR+23,I8)	! FAB$B_SHR
	      IF(I8.NE.0) THEN
		S_TMP=CHAR(9)//CHAR(9)//'SHR=<'
		LN=7
		DO I9=0,7
		  IF((I8.AND.JISHFT(1,I9)).NE.0)THEN
		    S_TMP(LN+1:)=C_FAB_SHR_CODES(I9)//','
		    LN=LN+4
		  ENDIF
		ENDDO
		S_TMP(LN:LN)='>,-'
		CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN+2))
	      ENDIF
	      CALL COPY_LONG(ADDR+36,I8)	! FAB$L_XAB
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'XAB=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      CALL COPY_LONG(ADDR+24,I8)	! FAB$L_CTX
	      K=FIND_P2_SYMBOL(%VAL(I8))
	      IF(K.GT.0)THEN
		CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX='//
     +						SYM_NAM(K)(1:LN))
	      ELSE
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'CTX=^X'//
     +						S_TMP(1:8))
	      ENDIF
	    ELSEIF(I2.EQ.'12'X)THEN	! XAB$C_DAT
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABDAT'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      K=FIND_P2_SYMBOL(%VAL(I8))
	      IF(K.GT.0)THEN
		CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN))
	      ELSE
		CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8))
	      ENDIF
	    ELSEIF(I2.EQ.'13'X)THEN	! XAB$C_PRO
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABPRO'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'14'X)THEN	! XAB$C_ALL
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABALL'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'15'X)THEN	! XAB$C_KEY
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABKEY'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'16'X)THEN	! XAB$C_SUM
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABSUM'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'1D'X)THEN	! XAB$C_FHC
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABFHC'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'1E'X)THEN	! XAB$C_RDT
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABRDT'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'1F'X)THEN	! XAB$C_TRM
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABTRM'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'20'X)THEN	! XAB$C_CXF
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABCXF'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'21'X)THEN	! XAB$C_CXR
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABCXR'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'22'X)THEN	! XAB$C_JNL
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABJNL'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ELSEIF(I2.EQ.'23'X)THEN	! XAB$C_RU
	      CALL WRITE_OUTPUT_TEXT(CHAR(9)//'$XABRU'//CHAR(9)//'-')
	      CALL COPY_LONG(ADDR+4,I8)		! XAB$L_NXT
	      IF(I8.NE.0) THEN
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT='//
     +						SYM_NAM(K)(1:LN)//',-')
		ELSE
		  CALL OTS$CVT_L_TZ(I8,S_TMP(1:8),%VAL(8))
		  CALL WRITE_OUTPUT_TEXT(CHAR(9)//CHAR(9)//'NXT=^X'//
     +						S_TMP(1:8)//',-')
		ENDIF
	      ENDIF
	      
	    ENDIF
	    ADDR=ADDR+I3
	    GOTO 2900
C
C  handler for FORTRAN precompiled FORMAT statement
C
 2220	    I2=0
	    DO WHILE (I2.NE.4)	! loop until end of format statement
	      I2=0
	      CALL COPY_BYTE(ADDR,I2)
	      ADDR=ADDR+1
	      I3=0
	      IF((I2.AND.'80'X).NE.0)THEN	! if X bit set
		CALL COPY_BYTE(ADDR,I3)		! get representation size byte
		ADDR=ADDR+1
	      ENDIF
	      GOTO (22200,22201,22202,22203,22204,22205,22206,22207,
     +		    22298,22209,22210,22211,22212,22213,22214,22215,
     +		    22216,22217,22218,22219,22220,22221,22222,22223,
     +		    22224,22225,22226,22227,22228,22298,22230,22231,
     +		    22232,22233,22234,22235,22298,22298,22298,22298,
     +		    22298,22241,22242,22243,22244,22245,22298,22298,
     +		    22298,22298,22250,22251,22252,22253), (I2.AND.'7F'X)+1
22200		WRITE(2,
     +'(A1,5H.BYTE,A1,2H^X,Z2.2,2A1,''; format syntax error'')')
     +				TAB, TAB, I2, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
92220		  FORMAT(A1,'.BYTE',A1,'^X',Z2.2,2A1,'; RS/S/VFEM byte')
		ENDIF
		GOTO 22299
22201		WRITE(2,
     +'(A1,5H.BYTE,A1,''1'',2A1,''; ( format reversion point'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22202		WRITE(2,
     +'(A1,5H.BYTE,A1,1H2,2A1,''; n( left paren, repeat group'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22203		WRITE(2,
     +'(A1,5H.BYTE,A1,1H3,2A1,''; ) right paren, repeat group'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22204		WRITE(2,
     +'(A1,5H.BYTE,A1,1H4,2A1,''; ) end of format'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22205		WRITE(2,
     +'(A1,5H.BYTE,A1,1H5,2A1,''; / record separator'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22206		WRITE(2,
     +'(A1,5H.BYTE,A1,1H6,2A1,''; $ terminal I/O'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22207		WRITE(2,
     +'(A1,5H.BYTE,A1,1H7,2A1,''; : terminate if end of list'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22209		WRITE(2,
     +'(A1,5H.BYTE,A1,1H9,2A1,''; S default optional plus sign'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22210		WRITE(2,
     +'(A1,5H.BYTE,A1,2H10,2A1,''; SP force optional plus sign'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22211		WRITE(2,
     +'(A1,5H.BYTE,A1,2H11,2A1,''; SS omit optional plus sign'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22212		WRITE(2,
     +'(A1,5H.BYTE,A1,2H12,2A1,''; sP  signed scale factor'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		IF((I3.AND.'40'X).NE.0)THEN	! if VFEM W bit set
		  CALL COPY_LONG(ADDR,I9)	! get VFE address
		  ADDR=ADDR+4
		  I9=I9+ADDR
		  WRITE(2,
     +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE scale factor'')')
     +				TAB, TAB, I9, TAB, TAB
		ELSE
		  IF((I3.AND.'4'X).EQ.0)THEN
		    CALL COPY_BYTE(ADDR,REC_TYP)
		    ADDR=ADDR+1
		    WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; scale factor'')')
     +				TAB, TAB, REC_TYP, TAB, TAB
		  ELSE
		    CALL COPY_WORD(ADDR,LN)
		    ADDR=ADDR+2
		    WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; scale factor'')')
     +				TAB, TAB, LN, TAB, TAB
		  ENDIF
		ENDIF
		GOTO 22299
22213		WRITE(2,
     +'(A1,5H.BYTE,A1,2H13,2A1,''; Tn  tab set'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		IF((I3.AND.'40'X).NE.0)THEN	! if VFEM W bit set
		  CALL COPY_LONG(ADDR,I9)	! get VFE address
		  ADDR=ADDR+4
		  I9=I9+ADDR
		  WRITE(2,
     +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE tab position'')')
     +				TAB, TAB, I9, TAB, TAB
		ELSE
		  I9=0
		  IF((I3.AND.'4'X).EQ.0)THEN
		    CALL COPY_BYTE(ADDR,I9)
		    ADDR=ADDR+1
		    WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; tab position'')')
     +				TAB, TAB, I9, TAB, TAB
		  ELSE
		    CALL COPY_WORD(ADDR,I9)
		    ADDR=ADDR+2
		    WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; tab position'')')
     +				TAB, TAB, I9, TAB, TAB
		  ENDIF
		ENDIF
		GOTO 22299
22214		WRITE(2,
     +'(A1,5H.BYTE,A1,2H14,2A1,''; nX (obsolete)'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		IF((I3.AND.'40'X).NE.0)THEN	! if VFEM W bit set
		  CALL COPY_LONG(ADDR,I9)	! get VFE address
		  ADDR=ADDR+4
		  I9=I9+ADDR
		  WRITE(2,
     +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE offset'')')
     +				TAB, TAB, I9, TAB, TAB
		ELSE
		  I9=0
		  IF((I3.AND.'4'X).EQ.0)THEN
		    CALL COPY_BYTE(ADDR,I9)
		    ADDR=ADDR+1
		    WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; offset'')')
     +				TAB, TAB, I9, TAB, TAB
		  ELSE
		    CALL COPY_WORD(ADDR,I9)
		    ADDR=ADDR+2
		    WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; offset'')')
     +				TAB, TAB, I9, TAB, TAB
		  ENDIF
		ENDIF
		GOTO 22299
22215		WRITE(2,
     +'(A1,5H.BYTE,A1,2H15,2A1,''; nHc1c2...cn Hollerith text'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		I9=0
		IF((I3.AND.'4'X).EQ.0)THEN
		  CALL COPY_BYTE(ADDR,I9)
		  ADDR=ADDR+1
		  WRITE(2,'(A1,5H.BYTE,A1,I5,2A1,''; length of string'')')
     +				TAB, TAB, I9, TAB, TAB
		ELSE
		  CALL COPY_WORD(ADDR,I9)
		  ADDR=ADDR+2
		  WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; length of string'')')
     +				TAB, TAB, I9, TAB, TAB
		ENDIF
		DO I8=1,I9
		  CALL COPY_BYTE(ADDR,%REF(S_TMP(I8:I8)))
		  ADDR=ADDR+1
		ENDDO
		K=STR$FIND_FIRST_NOT_IN_SET(STR_DELIM,S_TMP(1:I9))
		CALL SYS$FAO('!_.ASCII!_!AS!AD!AS',LN,CMD_LIN,STR_DELIM(K:K),
     +				%VAL(I9),%REF(S_TMP),
     +				STR_DELIM(K:K))
		WRITE(2,'(A)') CMD_LIN(1:LN)
		GOTO 22299
22216		WRITE(2,
     +'(A1,5H.BYTE,A1,2H16,2A1,''; BN blanks are nulls'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22217		WRITE(2,
     +'(A1,5H.BYTE,A1,2H17,2A1,''; BZ blanks are zeros'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22218		WRITE(2,'(A1,5H.BYTE,A1,2H18,2A1,''; TLc'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		IF((I3.AND.'40'X).NE.0)THEN	! if VFEM W bit set
		  CALL COPY_LONG(ADDR,I9)	! get VFE address
		  ADDR=ADDR+4
		  I9=I9+ADDR
		  WRITE(2,
     +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE offset'')')
     +				TAB, TAB, I9, TAB, TAB
		ELSE
		  I9=0
		  IF((I3.AND.'4'X).EQ.0)THEN
		    CALL COPY_BYTE(ADDR,I9)
		    ADDR=ADDR+1
		    WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; offset'')')
     +				TAB, TAB, I9, TAB, TAB
		  ELSE
		    CALL COPY_WORD(ADDR,I9)
		    ADDR=ADDR+2
		    WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; offset'')')
     +				TAB, TAB, I9, TAB, TAB
		  ENDIF
		ENDIF
		GOTO 22299
22219		WRITE(2,'(A1,5H.BYTE,A1,2H19,2A1,''; TRc'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		IF((I3.AND.'40'X).NE.0)THEN	! if VFEM W bit set
		  CALL COPY_LONG(ADDR,I9)	! get VFE address
		  ADDR=ADDR+4
		  I9=I9+ADDR
		  WRITE(2,
     +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE offset'')')
     +				TAB, TAB, I9, TAB, TAB
		ELSE
		  I9=0
		  IF((I3.AND.'4'X).EQ.0)THEN
		    CALL COPY_BYTE(ADDR,I9)
		    ADDR=ADDR+1
		    WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; offset'')')
     +				TAB, TAB, I9, TAB, TAB
		  ELSE
		    CALL COPY_WORD(ADDR,I9)
		    ADDR=ADDR+2
		    WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; offset'')')
     +				TAB, TAB, I9, TAB, TAB
		  ENDIF
		ENDIF
		GOTO 22299
22220		WRITE(2,
     +'(A1,5H.BYTE,A1,2H20,2A1,''; Q return remaining record len'')')
     +				TAB, TAB, TAB, TAB
		GOTO 22299
22221		WRITE(2,'(A1,5H.BYTE,A1,2H21,2A1,''; nAw'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		GOTO 22299
22222		WRITE(2,'(A1,5H.BYTE,A1,2H22,2A1,''; nLw'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		GOTO 22299
22223		WRITE(2,'(A1,5H.BYTE,A1,2H23,2A1,''; nOw'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		GOTO 22299
22224		WRITE(2,'(A1,5H.BYTE,A1,2H24,2A1,''; nIw'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		GOTO 22299
22225		WRITE(2,'(A1,5H.BYTE,A1,2H25,2A1,''; nZw'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		GOTO 22299
22226		WRITE(2,'(A1,5H.BYTE,A1,2H26,2A1,''; nOw.d'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		GOTO 22299
22227		WRITE(2,'(A1,5H.BYTE,A1,2H27,2A1,''; nIw.d'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		GOTO 22299
22228		WRITE(2,'(A1,5H.BYTE,A1,2H28,2A1,''; nZw.d'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		GOTO 22299
22230		WRITE(2,'(A1,5H.BYTE,A1,2H30,2A1,''; nFw.d'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		GOTO 22299
22231		WRITE(2,'(A1,5H.BYTE,A1,2H31,2A1,''; nEw.d'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		GOTO 22299
22232		WRITE(2,'(A1,5H.BYTE,A1,2H32,2A1,''; nGw.d'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		GOTO 22299
22233		WRITE(2,'(A1,5H.BYTE,A1,2H33,2A1,''; nDw.d'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		GOTO 22299
22234		WRITE(2,'(A1,5H.BYTE,A1,2H34,2A1,''; nEw.d.e'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		CALL WRITE_FORMAT_EXPONENT(ADDR,I3)
		GOTO 22299
22235		WRITE(2,'(A1,5H.BYTE,A1,2H35,2A1,''; nGw.d.e'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		CALL WRITE_FORMAT_WIDTH(ADDR,I3)
		CALL WRITE_FORMAT_MANTISSA(ADDR,I3)
		CALL WRITE_FORMAT_EXPONENT(ADDR,I3)
		GOTO 22299
22241		WRITE(2,
     +'(A1,5H.BYTE,A1,2H41,2A1,''; nA  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22242		WRITE(2,
     +'(A1,5H.BYTE,A1,2H42,2A1,''; nL  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22243		WRITE(2,
     +'(A1,5H.BYTE,A1,2H43,2A1,''; nO  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22244		WRITE(2,
     +'(A1,5H.BYTE,A1,2H44,2A1,''; nI  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22245		WRITE(2,
     +'(A1,5H.BYTE,A1,2H45,2A1,''; nZ  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22250		WRITE(2,
     +'(A1,5H.BYTE,A1,2H50,2A1,''; nF  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22251		WRITE(2,
     +'(A1,5H.BYTE,A1,2H51,2A1,''; nE  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22252		WRITE(2,
     +'(A1,5H.BYTE,A1,2H52,2A1,''; nG  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22253		WRITE(2,
     +'(A1,5H.BYTE,A1,2H53,2A1,''; nD  default format'')')
     +				TAB, TAB, TAB, TAB
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
		CALL WRITE_FORMAT_REPEAT(ADDR,I3)
		GOTO 22299
22298		WRITE(2,92221) TAB, TAB, I2, TAB, TAB
92221		FORMAT(A1,5H.BYTE,A1,'^X',Z2.2,2A1,'; unused format code')
		IF((I2.AND.'80'X).NE.0)THEN
		  WRITE(2,92220) TAB, TAB, I3, TAB, TAB
		ENDIF
22299	      CONTINUE
	    ENDDO
	    GOTO 2900
C
C  handler for driver prolog table (DPT) type
C
 2230	    WRITE(2,92300) form_feed, TAB, TAB,
     +			   DPT.T_NAME(1:DPT.B_NAMELEN), TAB, TAB, TAB, TAB,
     +			   DPT.W_VERSION
92300	    FORMAT(A1/
     +		   A1,'.SBTTL',A1,A,' Driver Prologue Table'/
     +		   ';'/
     +		   ';  Driver prologue table'/
     +		   ';'/
     +		   A1,'DPTAB',A1,'-',2A1,'; version',I2,' VMS')
	    K=FIND_P2_SYMBOL(%VAL(DPT.W_SIZE))
	    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	    WRITE(2,92301) TAB, TAB, SYM_NAM(K)(1:LN)
92301	    FORMAT(2A1,'END=',A,',-')
	    WRITE(2,92302) TAB, TAB, ADAPTER_NAME(DPT.B_ADPTYPE)
92302	    FORMAT(2A1,'ADAPTER=',A,',-')
	    IF(DPT.B_FLAGS .NE.0)THEN
	      S_TMP=' '
	      LN=0
	      IF((DPT.B_FLAGS .AND.1).NE.0)THEN
		S_TMP='DPT$M_SUBCNTRL'
		LN=14
	      ENDIF
	      IF((DPT.B_FLAGS .AND.2).NE.0)THEN
		S_TMP='+DPT$M_SVP'
		LN=LN+10
	      ENDIF
	      IF((DPT.B_FLAGS .AND.4).NE.0)THEN
		S_TMP='+DPT$M_NOUNLOAD'
		LN=LN+15
	      ENDIF
	      IF((DPT.B_FLAGS .AND.8).NE.0)THEN
		S_TMP='+DPT$M_SCS'
		LN=LN+10
	      ENDIF
	      WRITE(2,92303) TAB, TAB, S_TMP(1:LN)
92303	      FORMAT(2A1,'FLAGS=',A,',-')
	    ENDIF
	    WRITE(2,92304) TAB, TAB, DPT.W_UCBSIZE
92304	    FORMAT(2A1,'UCBSIZE=',I4,',-')
	    IF(DPT.W_UNLOAD .NE.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DPT.W_UNLOAD))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92305) TAB, TAB, SYM_NAM(K)(1:LN)
92305	      FORMAT(2A1,'UNLOAD=',A,',-')
	    ENDIF
	    IF(DPT.W_MAXUNITS .NE.8)THEN
	      WRITE(2,92306) TAB, TAB, DPT.W_MAXUNITS
92306	      FORMAT(2A1,'MAXUNITS=',I5,',-')
	    ENDIF
	    IF(DPT.W_DEFUNITS .NE.1)THEN
	      WRITE(2,92307) TAB, TAB, DPT.W_DEFUNITS
92307	      FORMAT(2A1,'DEFUNITS=',I2,',-')
	    ENDIF
	    IF(DPT.W_DELIVER .NE.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DPT.W_DELIVER))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92308) TAB, TAB, SYM_NAM(K)(1:LN)
92308	      FORMAT(2A1,'DELIVER=',A,',-')
	    ENDIF
	    IF(DPT.W_VECTOR .NE.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DPT.W_VECTOR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92309) TAB, TAB, SYM_NAM(K)(1:LN)
92309	      FORMAT(2A1,'VECTOR=',A,',-')
	    ENDIF
	    WRITE(2,92310) TAB, TAB, DPT.T_NAME(1:DPT.B_NAMELEN)
92310	    FORMAT(2A1,'NAME=',A)
	    ADDR=ADDR+DPT.W_INITTAB
	    GOTO 2900
C
C  handler for driver dispatch table (DDT) type
C
 2240	    WRITE(2,92400) TAB, TAB, TAB, TAB, DPT.T_NAME(1:2)
92400	    FORMAT(';'/
     +		   ';  Driver dispatch table'/
     +		   ';'/
     +		   A1,'DDTAB',A1,'-'/
     +		   2A1,'DEVNAM=',A,',-')
	    IF(DDT.L_START .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_START+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92401) TAB, TAB, SYM_NAM(K)(1:LN)
92401	      FORMAT(2A1,'START=',A,',-')
	    ENDIF
	    IF(DDT.L_UNSOLINT .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_UNSOLINT+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92402) TAB, TAB, SYM_NAM(K)(1:LN)
92402	      FORMAT(2A1,'UNSOLIC=',A,',-')
	    ENDIF
	    IF(DDT.L_CANCEL .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_CANCEL+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92403) TAB, TAB, SYM_NAM(K)(1:LN)
92403	      FORMAT(2A1,'CANCEL=',A,',-')
	    ENDIF
	    IF(DDT.L_REGDUMP .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_REGDUMP+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92404) TAB, TAB, SYM_NAM(K)(1:LN)
92404	      FORMAT(2A1,'REGDMP=',A,',-')
	    ENDIF
	    IF(DDT.W_DIAGBUF .NE.0)THEN
	      WRITE(2,92405) TAB, TAB, DDT.W_DIAGBUF
92405	      FORMAT(2A1,'DIAGBF=',I3,',-')
	    ENDIF
	    IF(DDT.W_ERRORBUF .NE.0)THEN
	      WRITE(2,92406) TAB, TAB, DDT.W_ERRORBUF
92406	      FORMAT(2A1,'ERLGBF=',I3,',-')
	    ENDIF
	    IF(DDT.L_UNITINIT .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_UNITINIT+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92407) TAB, TAB, SYM_NAM(K)(1:LN)
92407	      FORMAT(2A1,'UNITINIT=',A,',-')
	    ENDIF
	    IF(DDT.L_ALTSTART .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_ALTSTART+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92408) TAB, TAB, SYM_NAM(K)(1:LN)
92408	      FORMAT(2A1,'ALTSTART=',A,',-')
	    ENDIF
	    IF(DDT.L_MNTVER .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTVER+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92409) TAB, TAB, SYM_NAM(K)(1:LN)
92409	      FORMAT(2A1,'MNTVER=',A,',-')
	    ENDIF
	    IF(DDT.L_CLONEDUCB .GT.0)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_CLONEDUCB+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92410) TAB, TAB, SYM_NAM(K)(1:LN)
92410	      FORMAT(2A1,'CLONEDUCB=',A,',-')
	    ENDIF
	    IF(DDT.L_MNTV_SSSC .GT.0.AND.
     +	       DDT.L_FDT .GE.48)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTV_SSSC+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92411) TAB, TAB, SYM_NAM(K)(1:LN)
92411	      FORMAT(2A1,'MNTV_SSSC=',A,',-')
	    ENDIF
	    IF(DDT.L_MNTV_FOR .GT.0.AND.
     +	       DDT.L_FDT .GE.52)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTV_FOR+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92412) TAB, TAB, SYM_NAM(K)(1:LN)
92412	      FORMAT(2A1,'MNTV_FOR=',A,',-')
	    ENDIF
	    IF(DDT.L_MNTV_SQD .GT.0.AND.
     +	       DDT.L_FDT .GE.56)THEN
	      K=FIND_P2_SYMBOL(%VAL(DDT.L_MNTV_SQD+DDT_ADR))
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,92413) TAB, TAB, SYM_NAM(K)(1:LN)
92413	      FORMAT(2A1,'MNTV_SQD=',A,',-')
	    ENDIF
	    K=FIND_P2_SYMBOL(%VAL(DDT.L_FDT+DDT_ADR))
	    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	    WRITE(2,92414) TAB, TAB, SYM_NAM(K)(1:LN)
92414	    FORMAT(2A1,'FUNCTB=',A)
	    ADDR=ADDR+DDT.L_FDT
	    GOTO 2900
C
C  handler for driver initialization table
C
 2250	    K=FIND_P2_SYMBOL(%VAL(ADDR))
	    IF(K.GT.0)THEN
	      WRITE(2,92500) TAB, TAB
92500	      FORMAT(/A1,'DPT_STORE',A1,'INIT'/)
	    ENDIF
	    GOTO 2261
C
C  handler for driver reinitialization table
C
 2260	    K=FIND_P2_SYMBOL(%VAL(ADDR))
	    IF(K.GT.0)THEN
	      WRITE(2,92600) TAB, TAB
92600	      FORMAT(/A1,'DPT_STORE',A1,'REINIT'/)
	    ENDIF
 2261	    I2=0
	    CALL COPY_BYTE(ADDR,I2)	! structure type
	    ADDR=ADDR+1
	    IF(I2.EQ.0)THEN
	      WRITE(2,92601) TAB, TAB
92601	      FORMAT(/A1,'DPT_STORE',A1,'END'/)
	      ADDR=((ADDR+3)/4)*4	! move to next longword boundary
	    ELSE
	      I3=0
	      CALL COPY_BYTE(ADDR,I3)	! offset
	      ADDR=ADDR+1
	      I9=0
	      CALL COPY_BYTE(ADDR,I9)	! operation
	      ADDR=ADDR+1
	      I8=0
	      IF(I9.EQ.0)THEN
		CALL COPY_BYTE(ADDR,I8)
		ADDR=ADDR+1
		WRITE(2,92602) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92602		FORMAT(A1,'DPT_STORE',A1,A,',',I3,',B,<^X',Z2.2,'>')
	      ELSEIF(I9.EQ.1)THEN
		CALL COPY_WORD(ADDR,I8)
		ADDR=ADDR+2
		WRITE(2,92603) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92603		FORMAT(A1,'DPT_STORE',A1,A,',',I3,',W,<^X',Z4.4,'>')
	      ELSEIF(I9.EQ.2)THEN
		CALL COPY_WORD(ADDR,I8)
		ADDR=ADDR+2
		K=FIND_P2_SYMBOL(%VAL(I8))
		IF(K.GT.0)THEN
		  CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		  WRITE(2,92604) TAB, TAB, BLOCK_TYPE(I2), I3, SYM_NAM(K)(1:LN)
92604		  FORMAT(A1,'DPT_STORE',A1,A,',',I3,',D,',A)
		ELSE
		  WRITE(2,92606) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92606		  FORMAT(A1,'DPT_STORE',A1,A,',',I3,',D,<^X',Z4.4,'>')
		ENDIF
	      ELSE
		CALL COPY_LONG(ADDR,I8)
		ADDR=ADDR+4
		IF(I9.EQ.3)THEN
		  WRITE(2,92605) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92605		  FORMAT(A1,'DPT_STORE',A1,A,',',I3,',L,<^X',Z8.8,'>')
		ELSEIF(I9.EQ.'80'X)THEN
		  K=FIND_P2_SYMBOL(%VAL(I8))
		  IF(K.GT.0)THEN
		    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		    WRITE(2,92607) TAB, TAB, BLOCK_TYPE(I2), I3,
     +					SYM_NAM(K)(1:LN)
92607		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@B,',A)
		  ELSE
		    WRITE(2,92608) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92608		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@B,<^X',Z8.8,'>')
		  ENDIF
		ELSEIF(I9.EQ.'81'X)THEN
		  K=FIND_P2_SYMBOL(%VAL(I8))
		  IF(K.GT.0)THEN
		    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		    WRITE(2,92609) TAB, TAB, BLOCK_TYPE(I2), I3,
     +					SYM_NAM(K)(1:LN)
92609		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@W,',A)
		  ELSE
		    WRITE(2,92610) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92610		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@W,<^X',Z8.8,'>')
		  ENDIF
		ELSEIF(I9.EQ.'82'X)THEN
		  K=FIND_P2_SYMBOL(%VAL(I8))
		  IF(K.GT.0)THEN
		    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		    WRITE(2,92611) TAB, TAB, BLOCK_TYPE(I2), I3,
     +					SYM_NAM(K)(1:LN)
92611		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@D,',A)
		  ELSE
		    WRITE(2,92612) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92612		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@D,<^X',Z8.8,'>')
		  ENDIF
		ELSEIF(I9.EQ.'83'X)THEN
		  K=FIND_P2_SYMBOL(%VAL(I8))
		  IF(K.GT.0)THEN
		    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		    WRITE(2,92613) TAB, TAB, BLOCK_TYPE(I2), I3,
     +					SYM_NAM(K)(1:LN)
92613		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@L,',A)
		  ELSE
		    WRITE(2,92614) TAB, TAB, BLOCK_TYPE(I2), I3, I8
92614		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@L,<^X',Z8.8,'>')
		  ENDIF
		ELSEIF((I9.AND.'7F'X).EQ.4)THEN
		  LN=0
		  CALL COPY_BYTE(ADDR,LN)
		  ADDR=ADDR+1
		  K=0
		  CALL COPY_BYTE(ADDR,K)
		  ADDR=ADDR+1
		  IF((I9.AND.'80'X).NE.0)THEN
		    WRITE(2,92615) TAB, TAB, BLOCK_TYPE(I2), I3, I8, LN, K
92615		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',@V,<^X',Z8.8,
     +				'>,',I2,',',I2)
		  ELSE
		    WRITE(2,92616) TAB, TAB, BLOCK_TYPE(I2), I3, I8, LN, K
92616		    FORMAT(A1,'DPT_STORE',A1,A,',',I3,',V,<^X',Z8.8,
     +				'>,',I2,',',I2)
		  ENDIF
		ELSE
		  WRITE(2,92617) TAB, TAB, BLOCK_TYPE(I2), I3, I9
92617		  FORMAT(A1,'DPT_STORE',A1,A,',',I3,
     +				',;**** unknown op: ',Z2.2)
		ENDIF
	      ENDIF
	    ENDIF
	    GOTO 2900
C
C  handler for function decision table (FDT) type
C
 2270	    DO I2=1,2
	      CALL COPY_LONG(ADDR,I_FLT(1))
	      ADDR=ADDR+4
	      CALL COPY_LONG(ADDR,I_FLT(2))
	      ADDR=ADDR+4
	      WRITE(2,92700) TAB, TAB
92700	      FORMAT(A1,'FUNCTAB',A1,',-')
	      CALL BUILD_IO_LIST(I_FLT,S_TMP,LN,LN2)
	      I3=INDEX(S_TMP(1:LN),',')
	      DO WHILE (I3.GT.0)
		WRITE(2,92701) TAB, TAB, S_TMP(1:I3)
92701		FORMAT(2A1,A,'-')
		S_TMP=S_TMP(I3+1:LN)
		LN=LN-I3
		I3=INDEX(S_TMP(1:LN),',')
	      ENDDO
	      WRITE(2,92702) TAB, TAB, S_TMP(1:LN)
92702	      FORMAT(2A1,A/)
	    ENDDO
	    I9=DDT.W_FDTSIZE-16
	    DO WHILE (I9.GT.0)
	      CALL COPY_LONG(ADDR,I_FLT(1))
	      ADDR=ADDR+4
	      CALL COPY_LONG(ADDR,I_FLT(2))
	      ADDR=ADDR+4
	      CALL COPY_LONG(ADDR,I_FLT(3))
	      ADDR=ADDR+4
	      I9=I9-12
	      IF(I_FLT(3).GT.0)THEN
		K=FIND_P2_SYMBOL(%VAL(I_FLT(3)+ADDR-12))
		CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		WRITE(2,92703) TAB, TAB, SYM_NAM(K)(1:LN)
92703		FORMAT(A1,'FUNCTAB',A1,A,',-')
	      ELSE
		K=FIND_P2_SYMBOL(%VAL(I_FLT(3)))
		CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		WRITE(2,92704) TAB, TAB, SYM_NAM(K)(1:LN)
92704		FORMAT(A1,'FUNCTAB',A1,'+',A,',-')
	      ENDIF
	      CALL BUILD_IO_LIST(I_FLT,S_TMP,LN,LN2)
	      I3=INDEX(S_TMP(1:LN),',')
	      DO WHILE (I3.GT.0)
		WRITE(2,92701) TAB, TAB, S_TMP(1:I3)
		S_TMP=S_TMP(I3+1:LN)
		LN=LN-I3
		I3=INDEX(S_TMP(1:LN),',')
	      ENDDO
	      WRITE(2,92702) TAB, TAB, S_TMP(1:LN)
	    ENDDO
	    GOTO 2900
C
 2899	    CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
 2900	    CONTINUE
C
	  ENDIF
	ENDDO
	GOTO 5000	! end of private section handler
C
C  begin demand zero section handler
C
 3000	DO WHILE (ADDR.LE.ISD_PGEND(I))
C
C  find the first symbol in symbol table equal to or greater than current
C    address
C
	  DO I2=1,SYM_TBL_PTR
	    IF(SYM_VAL(I2).GE.ADDR)THEN
	      K=I2
	      GOTO 3008
	    ENDIF
	  ENDDO
 3008	  J=K
	  I2=MIN(SYM_VAL(J),ISD_PGEND(I)+1)-ADDR
	  IF(SYM_VAL(J).EQ.ADDR)THEN
	    CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN)
	    LLV_CODEMODE=.FALSE.	! switch to data mode
	    CALL WRITE_OUTPUT_TEXT(SYM_NAM(J)(1:LN)//':')
	    I2=MIN(SYM_VAL(J+1),ISD_PGEND(I)+1)-SYM_VAL(J)
	  ELSE
	    J=J-1
	  ENDIF
C
C  extract data type code from last symbol type
C
	  DO I9=27,3,-1
	    IF((SYM_TYP(J).AND.JISHFT(1,I9)).NE.0)THEN
	      K=I9-2
	      GOTO 3029
	    ENDIF
	  ENDDO
 3029	  I3=I2/DTYP_SIZE(K)
	  IF(I3.EQ.0)THEN
	    I3=I2
	    K=1
	  ELSE
	    I2=I3*DTYP_SIZE(K)
	  ENDIF
C
C  generate the output text
C
	  CALL SYS$FAO('!_.BLK!AS!_!UL',LN,S_TMP,%DESCR(DTYP_C(K)),%VAL(I3))
	  CALL WRITE_OUTPUT_TEXT(S_TMP(1:LN))
	  ADDR=ADDR+I2
	ENDDO
	GOTO 5000	! end of demand zero section handler
C
C  begin shareable section handler
C
 4000	IF(FIXUPSEC_ISD.EQ.0)THEN
	  DO K=1,SYM_TBL_PTR
	    IF(SYM_VAL(K).GE.ISD_BASEVA(I).AND.
     +	       SYM_VAL(K).LE.ISD_PGEND(I))THEN
	      CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
	      WRITE(2,9400) TAB, TAB, SYM_NAM(K)(1:LN)
 9400	      FORMAT(A1,'.EXTRN',A1,A)
	    ENDIF
	  ENDDO
	ELSEIF(ISD(I).T_GBLNAM(ISD(I).B_GBLNAMLEN-3:ISD(I).B_GBLNAMLEN)
     +			.EQ.'_001')THEN
	  DO K=0,ISD(FIXUPSEC_ISD).W_PAGCNT-1
	    READ (1,REC=ISD(FIXUPSEC_ISD).L_VBN+K)
     +			(HDR_BUF(J),J=I*512,(K+1)*512-1)
	  ENDDO
	  K=1
	  DO WHILE (K.LE.IAF.L_SHRIMGCNT .AND.
     +		    ISD(I).T_GBLNAM(1:ISD(I).B_GBLNAMLEN-4).NE.
     +			FIX_SHL(K).T_IMGNAM(1:FIX_SHL(K).B_IMGNAMLEN))
	    K=K+1
	  ENDDO
	  IF(IAF.L_G_FIXOFF .NE.0)THEN
	    J=IAF.L_G_FIXOFF
	    OFFSET_VEC(0)=-1
	    OFFSET_VEC(1)=-1
	    DO WHILE (OFFSET_VEC(0).NE.0.AND.
     +		      OFFSET_VEC(1).NE.K)
	      CALL LIB$MOVC3(8,HDR_BUF(J),OFFSET_VEC)
	      J=J+8+4*OFFSET_VEC(0)
	    ENDDO
	    IF(OFFSET_VEC(0).NE.0)THEN
	      J=J-(4*OFFSET_VEC(0))+ISD_BASEVA(FIXUPSEC_ISD)
	      K=FIND_P2_SYMBOL(%VAL(J))
	      DO I2=1,OFFSET_VEC(0)
		CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN)
		WRITE(2,9400) TAB, TAB, SYM_NAM(K)(1:LN)
		K=K+1
	      ENDDO
	    ENDIF
	  ENDIF
	ENDIF
	GOTO 5000	! end of shareable section handler
C
C  begin fixup vector section handler
C
 4500	CUR_VBN=ISD(FIXUPSEC_ISD).L_VBN
	READ(1,REC=CUR_VBN) REC_BUF
	CUR_VA=ISD_BASEVA(FIXUPSEC_ISD)
	WRITE (2,9451) IAF.W_FLAGS, IAF.L_SHRIMGCNT, IAF.L_SHREXTRA
 9451	FORMAT(';  fix-up section:'/
     +	';     fixed information:'/
     +	';          flags: %X''',Z4.4,''''/
     +	';          shareable image count:',I2/
     +	';          extra image count:',I2)
	IF(IAF.L_SHRIMGCNT.GT.1)THEN
	  WRITE(2,9452)
 9452	  FORMAT(';'/
     +		 ';     shareable image list:'/
     +		 ';            0) this image')
	  DO K=1,IAF.L_SHRIMGCNT-1
	    IF(FIX_SHL(K).L_BASEVA .NE.0)THEN
	      WRITE(2,9453) K, FIX_SHL(K).T_IMGNAM(1:
     +					FIX_SHL(K).B_IMGNAMLEN),
     +				FIX_SHL(K).L_BASEVA
 9453	      FORMAT(';          ',I3,') ',A,' based at %X''',Z8.8,'''')
	    ELSE
	      WRITE(2,9454) K, FIX_SHL(K).T_IMGNAM(1:
     +					FIX_SHL(K).B_IMGNAMLEN)
 9454	      FORMAT(';          ',I3,') ',A)
	    ENDIF
	  ENDDO
	ENDIF
	IF(IAF.L_G_FIXOFF .NE.0)THEN
	  WRITE(2,9460)
 9460	  FORMAT(';'/
     +		 ';     G^ reference fixups')
	  K=IAF.L_G_FIXOFF+ISD_BASEVA(FIXUPSEC_ISD)
	  CALL COPY_LONG(K,I2)
	  DO WHILE (I2.NE.0)
	    K=K+4
	    CALL COPY_LONG(K,I3)
	    K=K+4
	    WRITE(2,9455) I2, I3,
     +		FIX_SHL(I3).T_IMGNAM(1:FIX_SHL(I3).B_IMGNAMLEN)
 9455	    FORMAT(';'/
     +		   ';      ',I4,' references to image',I2,' (',A,'):')
	    DO I9=1,I2,4
	      DO I3=0,MIN(3,I2-I9)
		CALL COPY_LONG(K+I3,I_FLT(I3+1))
		K=K+4
	      ENDDO
	      WRITE(2,9456) (I_FLT(I3+1),I3=0,MIN(3,I2-I9))
 9456	      FORMAT(';         ',4(3X,Z8.8:))
	    ENDDO
	    CALL COPY_LONG(K,I2)
	  ENDDO
	ENDIF
	IF(IAF.L_DOTADROFF .NE.0)THEN
	  WRITE(2,9457) ISD_BASEVA(1)
 9457	  FORMAT(';'/
     +	';     .ADDRESS reference fixups (relative to %X''',Z8.8,''')')
	  K=IAF.L_DOTADROFF+ISD_BASEVA(FIXUPSEC_ISD)
	  CALL COPY_LONG(K,I2)
	  DO WHILE (I2.NE.0)
	    K=K+4
	    CALL COPY_LONG(K,I3)
	    K=K+4
	    WRITE(2,9455) I2, I3,
     +		FIX_SHL(I3).T_IMGNAM(1:FIX_SHL(I3).B_IMGNAMLEN)
	    DO I9=1,I2
	      CALL COPY_LONG(K,I3)
	      K=K+4
	      WRITE(2,9456) I3
	    ENDDO
	    CALL COPY_LONG(K,I2)
	  ENDDO
	ENDIF
	IF(IAF.L_CHGPRTOFF .NE.0)THEN
	  K=IAF.L_CHGPRTOFF+ISD_BASEVA(FIXUPSEC_ISD)
	  CALL COPY_LONG(K,I2)
	  K=K+4
	  WRITE(2,9458) ISD_BASEVA(1)
 9458	  FORMAT(';'/
     +';     protection change fixups (relative to %X''',Z8.8,''')'/
     +';')
	  DO ICODE=1,I2
	    CALL COPY_LONG(K,I3)
	    I9=0
	    CALL COPY_WORD(K+4,I9)
	    I8=0
	    CALL COPY_WORD(K+6,I8)
	    K=K+8
	    WRITE(2,9459) I3, I9, PROT_NAME(I8)
 9459	    FORMAT(';          address: %X''',Z8.8,''', page count:',I4/
     +		   ';          protection: PRT$C_',A4)
	  ENDDO
	ENDIF
	GOTO 5000
C
C  begin (message) vector section handler
C
 4800	CUR_VBN=ISD(I).L_VBN
	READ(1,REC=CUR_VBN) REC_BUF
	CUR_VA=ISD_BASEVA(I)
	CALL LIB$MOVC3(32,REC_BUF(0),PLV)	! get privileged vector block
	IF(PLV.L_TYPE .EQ.1)THEN	! change mode vector, privileged
	  WRITE(2,9481) PLV.L_VERSION, PLV.L_VERSION
 9481	  FORMAT(';   Change-Mode Vector for privileged shareable image'/
     +		 ';'/
     +		 ';       for version ',A4,' (^X',Z8.8,')'/
     +		 ';')
	  CALL STR$TRIM(ISD_NAM(I),ISD_NAM(I),LN)
	  S_TMP=CHAR(9)//'.PSECT'//CHAR(9)//ISD_NAM(I)(1:LN)//
     +				',USR,CON,REL,RD,LCL,VEC,'
	  LN=LN+33
	  IF((ISD(I).L_FLAGS .AND.'8'X).NE.0)THEN		! ISD$M_WRT
	    S_TMP(LN:)='WRT,'
	    LN=LN+4
	  ELSE
	    S_TMP(LN:)='NOWRT,'
	    LN=LN+6
	  ENDIF
	  IF(ISD(I).W_SIZE .LT.0)THEN
	    S_TMP(LN:)='EXE,'
	    LN=LN+4
	  ELSE
	    S_TMP(LN:)='NOEXE,'
	    LN=LN+6
	  ENDIF
	  IF((ISD(I).L_FLAGS .AND.'200'X).EQ.0)THEN	! ISD$M_BASED
	    S_TMP(LN:)='PIC,'	! private or shareable PIC I-sect
	    LN=LN+4
	  ELSE
	    S_TMP(LN:)='NOPIC,'
	    LN=LN+6
	  ENDIF
	  IF((ISD(I).L_FLAGS .AND.'102'X).NE.0)THEN ! ISD$M_CRF, ISD$M_COPYALWAYS
	    S_TMP(LN:)='NOSHR,'
	    LN=LN+6
	  ELSE
	    S_TMP(LN:)='SHR,'
	    LN=LN+4
	  ENDIF
	  S_TMP(LN:)='LONG'
	  LN=LN+3
	  WRITE(2,'(A)') S_TMP(1:LN)
	  WRITE(2,9002)
	  WRITE(2,94811) TAB, TAB, TAB, TAB, TAB, PLV.L_VERSION, TAB
94811	  FORMAT(A1,'$PLVDEF'/
     +		 ';'/
     +		 A1,'.LONG',A1,'PLV$C_TYP_CMOD'/
     +A1,'.LONG',A1,'^X',Z8.8,A1,'; field for system version number')
	  IF(PLV.L_KERNEL .EQ.0)THEN
	    WRITE(2,94812) TAB, TAB, TAB, TAB, 'kernel-mode'
94812	    FORMAT(A1,'.LONG',A1,'0',2A1,'; no ',A,' dispatcher vector')
	  ELSE
	    K=FIND_P2_SYMBOL(%VAL(PLV.L_KERNEL+8+ISD_BASEVA(I)))
	    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2)
	    WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'kernel-mode'
94813	    FORMAT(A1,'.LONG',A1,A,'-.',A1,'; ',A,' dispatcher vector')
	  ENDIF
	  IF(PLV.L_EXEC .EQ.0)THEN
	    WRITE(2,94812) TAB, TAB, TAB, TAB, 'executive-mode'
	  ELSE
	    K=FIND_P2_SYMBOL(%VAL(PLV.L_EXEC+12+ISD_BASEVA(I)))
	    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2)
	    WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'executive-mode'
	  ENDIF
	  IF(PLV.L_USRUNDWN .EQ.0)THEN
	    WRITE(2,94812) TAB, TAB, TAB, TAB, 'user rundown'
	  ELSE
	    K=FIND_P2_SYMBOL(%VAL(PLV.L_USRUNDWN+16+ISD_BASEVA(I)))
	    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2)
	    WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'user rundown'
	  ENDIF
	  WRITE(2,94814) TAB, TAB, TAB, TAB
94814	  FORMAT(A1,'.LONG',A1,'0',2A1,'; (reserved)')
	  IF(PLV.L_RMS .EQ.0)THEN
	    WRITE(2,94812) TAB, TAB, TAB, TAB, 'RMS'
	  ELSE
	    K=FIND_P2_SYMBOL(%VAL(PLV.L_RMS+24+ISD_BASEVA(I)))
	    CALL STR$TRIM(SYM_NAM(K),SYM_NAM(K),LN2)
	    WRITE(2,94813) TAB, TAB, SYM_NAM(K)(1:LN2), TAB, 'RMS'
	  ENDIF
	  WRITE(2,94815) TAB, TAB, PLV.L_CHECK, TAB
94815	  FORMAT(A1,'.LONG',A1,'^X',Z8.8,A1,'; address check longword')
	  ADDR=ISD_BASEVA(I)+32
	  GOTO 2000		! treat like normal I-sect now
	ELSEIF(PLV.L_TYPE .EQ.2)THEN	! message vector
	  AUX_SYM_TBL(-1)=0
	  ADDR=ISD_BASEVA(I)+16
	  AUX_SYM_TBL(0)=-1
	  DO WHILE (AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0)
	    AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)+1
	    CALL COPY_LONG(ADDR,AUX_SYM_TBL(AUX_SYM_TBL(-1)))	! get offset
	    IF(AUX_SYM_TBL(AUX_SYM_TBL(-1)).NE.0)THEN
	      AUX_SYM_TBL(AUX_SYM_TBL(-1))=AUX_SYM_TBL(AUX_SYM_TBL(-1))+ADDR
	    ENDIF
	    ADDR=ADDR+4
	  ENDDO
	  AUX_SYM_TBL(-1)=AUX_SYM_TBL(-1)-1
	  WRITE(2,9482) AUX_SYM_TBL(-1)
 9482	  FORMAT(';   Message vector for image:'/
     +		 ';       contains',I3,' message sections')
	  DO I2=1,AUX_SYM_TBL(-1)
	    ADDR=AUX_SYM_TBL(I2)
	    CALL COPY_WORD(ADDR,LN)	! get message section type
	    ADDR=ADDR+4
	    CALL COPY_LONG(ADDR,I3)	! get section length
	    ADDR=ADDR+4
	    IF(LN.EQ.0)THEN		! if actual definitions here
	      CALL COPY_LONG(ADDR,I8)	! get offset to vector index
	      I8=I8+AUX_SYM_TBL(I2)
	      ADDR=ADDR+4
	      CALL COPY_LONG(ADDR,I9)	! get offset to facility name
	      I9=I9+AUX_SYM_TBL(I2)
	      ADDR=ADDR+4
	      CALL COPY_LONG(ADDR,J)	! get offset to string area
	      J=J+AUX_SYM_TBL(I2)
	      ADDR=ADDR+24
	      CALL COPY_WORD(ADDR,LN3)	! get last msg # in facility
	      LN=LN3/8-1
	      WRITE(2,94821) I2, I3, LN
94821	      FORMAT(';'/
     +	     ';    message section',I3,', len=',I6,' bytes,',I4,' msgs'/
     +	  	   ';')
	      CALL COPY_WORD(I9,LN2)
	      DO K=1,LN2
	        CALL COPY_BYTE(I9+1+K,%REF(FACILITY_BUF(K:K)))
	      ENDDO
	      LN=1
	      S_TMP=' '
	      IF((FACILITY_NUMBER.AND.'800'X).EQ.0)THEN
	        S_TMP='/SYSTEM'
	        LN=7
	      ELSE
		S_TMP='/PREFIX='//FACILITY_NAM(1:FACILITY_NAMLEN)//'__'
		LN=FACILITY_NAMLEN+10
	      ENDIF
	      LN2=FACILITY_NUMBER.AND..NOT.'800'X
	      WRITE(2,94822) S_TMP(1:LN), TAB,
     +			   FACILITY_NAM(1:FACILITY_NAMLEN), LN2, TAB
94822	      FORMAT('; .FACILITY',A,A1,A,',',I4/
     +		     '; !'/
     +		     '; .SEVERITY',A1,'WARNING')
	      ADDR=I8+8		! start at beginning of vector index
	      DO WHILE (ADDR.LT.J)	! scan until end of vector index
	        CALL COPY_LONG(ADDR,OFFSET_VEC(0))
	        ADDR=ADDR+4
	        CALL COPY_LONG(ADDR,OFFSET_VEC(1))
	        ADDR=ADDR+4
	        OFFSET_VEC(1)=OFFSET_VEC(1)+AUX_SYM_TBL(I2)
	        CALL COPY_STR(OFFSET_VEC(1),MESSAGE_BUF)
	        I8=ICHAR(MESSAGE_BUF(9:9))
		K=INDEX(MESSAGE_BUF(11+I8:10+I8+ICHAR(
     +				MESSAGE_BUF(10+I8:10+I8))),
     +			'"')
		IF(K.EQ.0)THEN
		  S_TMP(1:2)='""'
		ELSE
		  S_TMP(1:2)='<>'
		ENDIF
		K=INDEX(MESSAGE_BUF(11+I8:10+I8+ICHAR(
     +				MESSAGE_BUF(10+I8:10+I8))),
     +			'!/')
		IF(K.EQ.0)THEN
		  CALL SYS$FAO(
     +'; !AD/FAO=!UL!#</USER=%X!XB!>!_!AS!AD!AS!_!! !XL',
     +			   LN,CMD_LIN,
     +			   %VAL(I8),%REF(MESSAGE_BUF(10:)),
     +			   %VAL(MSG_FAOCOUNT),
     +			   %VAL(-10*(MSG_USERVALUE.NE.0)),%VAL(MSG_USERVALUE),
     +			   S_TMP(1:1),
     +			   %VAL(ICHAR(MESSAGE_BUF(10+I8:10+I8))),
     +				%REF(MESSAGE_BUF(11+I8:)),
     +			   S_TMP(2:2),
     +			   %VAL(OFFSET_VEC(0)))
		  WRITE(2,'(A)') CMD_LIN(1:LN)
		ELSE
		  CALL SYS$FAO(
     +'; !AD/FAO=!UL!#</USER=%X!XB!>!_!AS!AD!AS-',
     +			   LN,CMD_LIN,
     +			   %VAL(I8),%REF(MESSAGE_BUF(10:)),
     +			   %VAL(MSG_FAOCOUNT),
     +			   %VAL(-10*(MSG_USERVALUE.NE.0)),%VAL(MSG_USERVALUE),
     +			   S_TMP(1:1),
     +			   %VAL(K+1),%REF(MESSAGE_BUF(11+I8:)),
     +			   S_TMP(2:2))
		  WRITE(2,'(A)') CMD_LIN(1:LN)
		  I9=INDEX(MESSAGE_BUF(11+I8+K:10+I8+ICHAR(
     +				MESSAGE_BUF(10+I8:10+I8))),
     +			'!/')+K
		  DO WHILE (I9.GT.K)
		    CALL SYS$FAO(
     +';!_!_!_!AS!AD!AS-',
     +			   LN,CMD_LIN,
     +			   S_TMP(1:1),
     +			   %VAL(I9-K),%REF(MESSAGE_BUF(12+I8+K:)),
     +			   S_TMP(2:2))
		    WRITE(2,'(A)') CMD_LIN(1:LN)
		    K=I9
		    I9=INDEX(MESSAGE_BUF(11+I8+K:10+I8+ICHAR(
     +				MESSAGE_BUF(10+I8:10+I8))),
     +			'!/')+K
		  ENDDO
		  IF(K.NE.ICHAR(MESSAGE_BUF(10+I8:10+I8)))THEN
		    CALL SYS$FAO(
     +';!_!_!_!AS!AD!AS!_!! !XL',
     +			   LN,CMD_LIN,
     +			   S_TMP(1:1),
     +			   %VAL(ICHAR(MESSAGE_BUF(10+I8:10+I8))-(K+1)),
     +			   	%REF(MESSAGE_BUF(12+I8+K:)),
     +			   S_TMP(2:2),
     +			   %VAL(OFFSET_VEC(0)))
		    WRITE(2,'(A)') CMD_LIN(1:LN)
		  ELSE
		    CALL SYS$FAO(
     +';!_!_!_!_!! !XL',
     +			   LN,CMD_LIN,
     +			   %VAL(OFFSET_VEC(0)))
		    WRITE(2,'(A)') CMD_LIN(1:LN)
		  ENDIF
		ENDIF
	      ENDDO
	      WRITE(2,94824)
94824	      FORMAT('; !'/
     +		     '; .END')
	    ELSEIF(LN.EQ.1)THEN		! indirect file reference
	      LN=0
	      CALL COPY_BYTE(ADDR,LN)
	      ADDR=ADDR+1
	      DO I9=1,LN
		CALL COPY_BYTE(ADDR,%REF(S_TMP(I9:I9)))
		ADDR=ADDR+1
	      ENDDO
	      WRITE(2,94825) I2, I3, S_TMP(1:LN)
94825	      FORMAT(';'/
     +	';    message section',I3,', len=',I4,' bytes, file=''',A,'''')
	    ENDIF
	  ENDDO
	ELSE
	  CALL LIB$SIGNAL(DISM__UNRECVEC,%VAL(4),%VAL(I),
     +				%VAL(ISD(I).L_VBN),%VAL(ISD_BASEVA(I)),
     +				%VAL(PLV.L_TYPE))
	ENDIF
	GOTO 5000
C
 5000 CONTINUE
      ENDDO
      CALL LIB$REVERT
C
C  generate a .SYM file for future usage
C
      INQUIRE(UNIT=1,NAME=OUT_FIL)
      CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
      I=INDEX(OUT_FIL(1:LN),']')
      I=I+1
      J=INDEX(OUT_FIL(I:LN),'.')+I-2
      OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW',
     +	   FORM='FORMATTED',CARRIAGECONTROL='LIST',BLOCKSIZE=16384,
     +	   DEFAULTFILE='.SYM',INITIALSIZE=SYM_TBL_PTR/11)
      DO I=1,SYM_TBL_PTR
	SYM_TYP(I)=SYM_TYP(I).AND..NOT.SYM_DISM
	CALL STR$TRIM(SYM_NAM(I),SYM_NAM(I),LN)
	WRITE(99,'(2(Z8.8,X),I4,X,Z8.8,X,A)')
     +			SYM_VAL(I), SYM_TYP(I), SYM_EXT_ATTR(I),
     +			SYM_EXT_VAL(I), SYM_NAM(I)(1:LN)
      ENDDO
      CLOSE(UNIT=99)
C
C  generate a report file on the module and line number records
C
      IF(IHS.W_DSTBLKS .NE.0)THEN
	INQUIRE(UNIT=1,NAME=OUT_FIL)
	CALL STR$TRIM(OUT_FIL,OUT_FIL,LN)
	I=INDEX(OUT_FIL(1:LN),']')
	I=I+1
	J=INDEX(OUT_FIL(I:LN),'.')+I-2
	OPEN(UNIT=99,FILE=OUT_FIL(I:J),STATUS='NEW',
     +	     FORM='FORMATTED',CARRIAGECONTROL='LIST',BLOCKSIZE=16384,
     +	     DEFAULTFILE='.MOD_LIN',
     +	     INITIALSIZE=MOD_TBL_PTR/6+LIN_TBL_PTR/25)
	OLD_LINTB_PTR=1
	DO I=1,MOD_TBL_PTR
	  CALL STR$TRIM(MOD_NAM(I),MOD_NAM(I),LN)
	  WRITE(99,9700) MOD_NAM(I)(1:LN), LANGUAGE_NAME(MOD_LNG(I)),
     +			MOD_VERMAJ(I), MOD_VERMIN(I), MOD_START(I),
     +			MOD_END(I)
 9700	  FORMAT('MODULE=',A,X,A,' V',I2.2,'.',I2.2,2Z9.8)
	  J=OLD_LINTB_PTR
	  DO WHILE (J.LE.LIN_TBL_PTR.AND.
     +		    LIN_ADR(J).LT.MOD_START(I))
	    J=J+1
	  ENDDO
	  IF(J.LE.LIN_TBL_PTR)THEN
	    DO WHILE (LIN_ADR(J).LE.MOD_END(I).AND.
     +		      J.LE.LIN_TBL_PTR)
	      IF(LIN_STMT(J).EQ.1)THEN
		WRITE(99,9702) LIN_ADR(J), LIN_NUM(J)
 9702		FORMAT('LINE  =',Z8.8,I5)
	      ELSE
		WRITE(99,9703) LIN_ADR(J), LIN_NUM(J), LIN_STMT(J)
 9703		FORMAT('LINE  =',Z8.8,I5,'.',I2.2)
	      ENDIF
	      J=J+1
	    ENDDO
	  ENDIF
	  OLD_LINTB_PTR=J
	ENDDO
	CLOSE(UNIT=99)
      ENDIF
C
C  wind down the disassembler, close all files, and exit.
C
      WRITE(2,9002)
      IF((IHD.L_LNKFLAGS .AND.2).NE.0)THEN
	WRITE(2,9990)TAB
 9990	FORMAT(A1,'.END')
      ELSE
	DO I=1,3
	  J=1
	  DO WHILE (J.LE.ISD_NUM.AND.
     +		    (IHA.L_TFRADR(I) .LT.ISD_BASEVA(J).OR.
     +		     IHA.L_TFRADR(I) .GT.ISD_PGEND(J)))
	    J=J+1
	  ENDDO
	  IF(J.LE.ISD_NUM)THEN
	    I2=1
	    DO WHILE (I2.LE.SYM_TBL_PTR.AND.
     +		      IHA.L_TFRADR(I) .NE.SYM_VAL(I2))
	      I2=I2+1
	    ENDDO
	    CALL STR$TRIM(SYM_NAM(I2),SYM_NAM(I2),LN)
	    WRITE(2,9991) TAB,TAB,SYM_NAM(I2)(1:LN)
 9991	    FORMAT(A1,'.END',A1,A)
	    GOTO 999
	  ENDIF
	ENDDO
      ENDIF
  999 CLOSE(UNIT=1)
      CLOSE(UNIT=2)
      CALL LIB$PUT_OUTPUT('Statistics:')
      CALL SYS$FAO(
     +'!_generated !UL symbols, !UL modules, !UL line numbers',
     +LN,S_TMP,%VAL(SYM_TBL_PTR),%VAL(MOD_TBL_PTR),%VAL(LIN_TBL_PTR))
      CALL LIB$PUT_OUTPUT(S_TMP(1:LN))
      ICODE=LIB$SHOW_TIMER()
      IF(.NOT.ICODE)CALL LIB$SIGNAL(%VAL(ICODE))
C
      END
      INTEGER*4 FUNCTION FIX_BUFR_OVRFL(SIG_ARGS,MECH_ARGS)
C
C  this condition handler traps only for the DISM__INVBOFSET signal, and
C  resignals all others. If the signal occurs, the appropriate record from the
C  input file is read in, and the block virtual address is
C  adjusted to the new VBN.
C
      IMPLICIT NONE
      INTEGER*4 SIG_ARGS(*),MECH_ARGS(*)
      EXTERNAL DISM__INVBOFSET
      INTEGER*4 I
C
      INCLUDE 'DISMISDTBL.INC'
      INCLUDE 'DISMMISC.INC'
C
      IF(SIG_ARGS(2).EQ.%LOC(DISM__INVBOFSET))THEN
	I=1
	DO WHILE (I.LE.ISD_NUM)
	  IF(ISD_BASEVA(I).LE.SIG_ARGS(4).AND.
     +	     ISD_PGEND(I).GE.SIG_ARGS(4))THEN
	    GOTO 10
	  ENDIF
	  I=I+1
	ENDDO
	GOTO 90
   10	CUR_VBN=(SIG_ARGS(4)/512)-(ISD_BASEVA(I)/512)+ISD(I).L_VBN
	IF(ISD(I).L_VBN .NE.0)THEN
	  READ(1,REC=CUR_VBN) REC_BUF
	ELSE
	  CALL LIB$MOVC5(0,0,0,512,REC_BUF)
	  CUR_VBN=0
	ENDIF
	CUR_VA=SIG_ARGS(4).AND..NOT.'1FF'X
	FIX_BUFR_OVRFL=1	! return SS$_CONTINUE
      ELSE
   90	FIX_BUFR_OVRFL=0	! return SS$_RESIGNAL
      ENDIF
      RETURN
C
      END
      INTEGER*4 FUNCTION FIX_BUF_1(SIG_ARGS,MECH_ARGS)
C
C  this condition handler traps only for the DISM__INVBOFSET signal, and
C  resignals all others. If the signal occurs, the next record from the
C  input file is read in, the offset parameter used by the signaling
C  process has 512 subtracted from it, and the block virtual address is
C  incremented by 512.
C
      IMPLICIT NONE
      BYTE REC_BUF(0:511)
      INTEGER*4 SIG_ARGS(*),MECH_ARGS(*),CUR_VBN,CUR_VA
      EXTERNAL DISM__INVBOFSET
      COMMON /DSK_BUF/ CUR_VBN,REC_BUF,CUR_VA
C
      IF(SIG_ARGS(2).EQ.%LOC(DISM__INVBOFSET))THEN
	CUR_VBN=CUR_VBN+1
	CUR_VA=CUR_VA+512
	READ(1,REC=CUR_VBN) REC_BUF
	FIX_BUF_1=1		! return SS$_CONTINUE
      ELSE
	FIX_BUF_1=0		! return SS$_RESIGNAL
      ENDIF
      RETURN
C
      END
      INTEGER*4 FUNCTION FIX_BUF_3(SIG_ARGS,MECH_ARGS)
C
C  this condition handler traps only for the DISM__INVBOFSET signal, and
C  resignals all others. If the signal occurs, the next record from the
C  input file is read in, the offset parameter used by the signaling
C  process has 512 subtracted from it, and the block virtual address is
C  incremented by 512.
C
      IMPLICIT NONE
      BYTE REC_BUF(0:511)
      INTEGER*4 SIG_ARGS(*),MECH_ARGS(*),CUR_VBN,CUR_VA
      EXTERNAL DISM__INVBOFSET
      COMMON /DSK_BUF/ CUR_VBN,REC_BUF,CUR_VA
C
      IF(SIG_ARGS(2).EQ.%LOC(DISM__INVBOFSET))THEN
	CUR_VBN=CUR_VBN+1
	CUR_VA=CUR_VA+512
	READ(3,REC=CUR_VBN) REC_BUF
	FIX_BUF_3=1		! return SS$_CONTINUE
      ELSE
	FIX_BUF_3=0		! return SS$_RESIGNAL
      ENDIF
      RETURN
C
      END
      INTEGER*4 FUNCTION WRITE_OUTPUT_TEXT(LINE)
C
C  this procedure writes the passed string to the output file.
C
      IMPLICIT NONE
      CHARACTER*(*) LINE
C
      BYTE	B_TABS(6)
      INTEGER*4 I
      CHARACTER*6 TABS
      EQUIVALENCE (TABS, B_TABS)
      DATA B_TABS/6*9/
C
      INCLUDE 'DISMLINTBL.INC'
      INCLUDE 'DISMMISC.INC'
C
      I=OLD_LINTB_PTR
      DO WHILE (LIN_ADR(I).LT.CURR_ADR.AND.
     +		I.LE.LIN_TBL_PTR)
	I=I+1
      ENDDO
      OLD_LINTB_PTR=I
      IF(LIN_ADR(I).NE.CURR_ADR)THEN
	WRITE(2,'(A)')LINE
      ELSE
	IF(INDEX(LINE(2:),CHAR(9)).EQ.0)THEN
	  I=6
	ELSE
	  I=MAX(5-(LEN(LINE)-INDEX(LINE(2:),CHAR(9))-1)/8,1)
	ENDIF
	IF(LIN_STMT(I).EQ.1)THEN	
	  WRITE(2,9000) LINE, TABS(1:I), LIN_NUM(OLD_LINTB_PTR)
 9000	  FORMAT(/A,A,'; ',I4.4)
	ELSE
	  WRITE(2,9001) LINE, TABS(1:I), LIN_NUM(OLD_LINTB_PTR),
     +			LIN_STMT(OLD_LINTB_PTR)
 9001	  FORMAT(/A,A,'; ',I4.4,'.',I2.2)
	ENDIF
      ENDIF
      WRITE_OUTPUT_TEXT=1
      RETURN
C
      END
      INTEGER*4 FUNCTION WRITE_SYM_TBL(VAL,TYP,EXT_TYP,EXT_VAL)
C
C  This procedure checks for previous occurrences of the specified symbol
C  value and type pair, and then, if no previous occurrences show up, adds
C  the symbol entry to the end of the symbol table, raising the signal
C  DISM__SYMTBLOVF if the table is full.
C
      IMPLICIT NONE
      INTEGER*4 VAL, TYP, EXT_TYP, EXT_VAL
C
      INTEGER*4 I
C
      INCLUDE 'DISMSYMTBL.INC'
C
      EXTERNAL DISM__SYMTBLOVF
C
C  scan through the symbol table for a previous occurrence,
C
      I=1
      DO WHILE (I.LE.SYM_TBL_PTR.AND.
     +		SYM_VAL(I).NE.%LOC(VAL))
	I=I+1
      ENDDO
      IF(I.LE.SYM_TBL_PTR)THEN
	IF((SYM_TYP(I).AND.SYM_M_CODE).EQ.0.AND.
     +	   (%LOC(TYP).AND.SYM_M_CODE).NE.0)THEN
	  SYM_FOUND_NEW_CODE=.TRUE.
	ENDIF
	SYM_TYP(I)=SYM_TYP(I).OR.%LOC(TYP)
	IF((%LOC(TYP).AND.SYM_D_EXTENDED).NE.0.AND.
     +	   %LOC(EXT_TYP).GE.SYM_EXT_ATTR(I))THEN
	  SYM_EXT_ATTR(I)=%LOC(EXT_TYP)
	  SYM_EXT_VAL(I)=%LOC(EXT_VAL)
	ENDIF
      ELSE
C
C  not in table, add it (if not a table overflow)
C
	SYM_TBL_PTR=SYM_TBL_PTR+1
	IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN
	  CALL LIB$SIGNAL(DISM__SYMTBLOVF)
	ELSE
	  SYM_VAL(SYM_TBL_PTR)=%LOC(VAL)
	  SYM_TYP(SYM_TBL_PTR)=%LOC(TYP)
	  SYM_NAM(SYM_TBL_PTR)=' '
	  SYM_EXT_ATTR(SYM_TBL_PTR)=%LOC(EXT_TYP)
	  SYM_EXT_VAL(SYM_TBL_PTR)=%LOC(EXT_VAL)
	  SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X
	  IF((%LOC(TYP).AND.SYM_M_CODE).NE.0)THEN
	    SYM_FOUND_NEW_CODE=.TRUE.
	  ENDIF
	ENDIF
      ENDIF
C
C  exit with success
C
      WRITE_SYM_TBL=1
      RETURN
C
      END
      SUBROUTINE EXTRACT_SYM_TBL(STR,VAL)
C
C  This procedure extracts a symbol name from the symbol table corresponding
C    to the specified value, and appends the name to the passed
C    dynamic string.
C
      IMPLICIT NONE
      INTEGER*4 STR(2), VAL	! disguise to protect integrity of dynamic descriptor
C
      INTEGER*2 LN
      INTEGER*4 J
C
      INCLUDE 'DISMSYMTBL.INC'
C
      EXTERNAL DISM__NOSUCHSYM
      INTEGER*4 FIND_P2_SYMBOL
      EXTERNAL	FIND_P2_SYMBOL
C
      J=FIND_P2_SYMBOL(VAL)
      IF(J.GT.0)THEN
	CALL STR$TRIM(SYM_NAM(J),SYM_NAM(J),LN)
	CALL STR$APPEND(STR,SYM_NAM(J)(1:LN))
      ELSE
C
C  report error due to no match occurring
C
	CALL LIB$SIGNAL(DISM__NOSUCHSYM,%VAL(1),%VAL(%LOC(VAL)))
      ENDIF
C
C  exit
C
      RETURN
C
      END
      INTEGER*4 FUNCTION FIND_P2_SYMBOL(VAL)
C
C  This procedure attempts to locate an entry in the symbol table that
C    matches the specified symbol value
C
      IMPLICIT NONE
      INTEGER*4 VAL
C
      INTEGER*4 I, J, LAST_SYM_TBL/0/,	DELTA_BASE/0/
      SAVE LAST_SYM_TBL, DELTA_BASE
      INCLUDE 'DISMSYMTBL.INC'
C
C  scan by binary search through the symbol table looking for symbol in question
C
      IF(SYM_TBL_PTR.NE.LAST_SYM_TBL)THEN
	DELTA_BASE=2**INT(LOG(FLOAT(MAX(SYM_TBL_PTR,1)))/LOG(2.0))
	LAST_SYM_TBL=SYM_TBL_PTR
      ENDIF
      I=DELTA_BASE
      J=(SYM_TBL_PTR+1)/2
      DO WHILE (I.GE.1.AND.SYM_VAL(J).NE.%LOC(VAL))
	I=JISHFT(I,-1)
	IF(%LOC(VAL).LT.SYM_VAL(J))THEN
	  J=MAX(J-I,1)
	ELSEIF(%LOC(VAL).GT.SYM_VAL(J))THEN
	  J=MIN(J+I,SYM_TBL_PTR)
	ENDIF
      ENDDO
      IF(SYM_VAL(J).EQ.%LOC(VAL))THEN
	FIND_P2_SYMBOL=J
      ELSEIF(SYM_VAL(J).LT.%LOC(VAL))THEN
	FIND_P2_SYMBOL=-(J+1)
      ELSE
	FIND_P2_SYMBOL=-J
      ENDIF
C
      RETURN
C
      END
      INTEGER*4 FUNCTION GET_SYMBOL_TYPE(VAL)
C
C  This procedure extracts the type flags for a symbol table entry.
C
      IMPLICIT NONE
      INTEGER*4 VAL	! disguise to protect integrity of dynamic descriptor
C
      INTEGER*4 I
C
      INCLUDE 'DISMSYMTBL.INC'
C
      INTEGER*4 FIND_P2_SYMBOL
      EXTERNAL	FIND_P2_SYMBOL
      EXTERNAL DISM__NOSUCHSYM
C
C  scan through the symbol table looking for the symbol in question
C
      I=FIND_P2_SYMBOL(%VAL(%LOC(VAL)))
      IF(I.GT.0)THEN
	GET_SYMBOL_TYPE=SYM_TYP(I)
      ELSE
C
C  report error due to no match occurring
C
	CALL LIB$SIGNAL(DISM__NOSUCHSYM,%VAL(1),VAL)
      ENDIF
C
C  exit
C
   99 RETURN
C
      END
      SUBROUTINE NAME_SYM_TBL(REC_COUNT,OFFSET_VEC,SYM_TBL)
C
C  This procedure will read and analyze the Object Language records from the
C    global symbol table areas of the input image or VMSRTL.EXE
C    and use the symbol names in them, where appropriate, to fill in the
C    symbol name fields in the symbol table.
C
      IMPLICIT NONE
      BYTE REC,SUBREC
      INTEGER*4 OFFSET_VEC,	SYM_TBL(-1:*)
C
      CHARACTER*2048 LINE
      INTEGER*4 REC_COUNT, I, POS, K, I2, J
C
      INTEGER*4 ANALYZE_SYM_REC
      EXTERNAL	ANALYZE_SYM_REC
C
C  read record length from input file
C
      POS=0
      DO I=1,IABS(REC_COUNT)
	K=0
	CALL COPY_WORD(POS,K)
	POS=POS+2
C
C  if non-zero length, read rest of record
C
	IF(K.NE.0)THEN
	  CALL COPY_BYTE(POS,REC)
	  POS=POS+1
	  CALL COPY_BYTE(POS,SUBREC)
	  POS=POS+1
	  DO I2=1,K-2
	    CALL COPY_BYTE(POS,%REF(LINE(I2:I2)))
	    POS=POS+1
	  ENDDO
	  IF(REC_COUNT.LT.0)THEN
	    WRITE(99) REC, SUBREC, LINE(1:K-2)
	  ENDIF
	  J=ANALYZE_SYM_REC(REC,SUBREC,LINE(1:MAX(K-2,1)),
     +			    OFFSET_VEC,SYM_TBL)
	  IF(J.NE.0)GOTO 99
	  IF(MOD(POS,2).NE.0)POS=POS+1
	ENDIF
      ENDDO
C
C  exit now that entire set of records has been processed
C
   99 RETURN
C
      END
      SUBROUTINE MAKE_MASK(LINE,VALUE,ENDPOS)
C
C  This procedure will construct the text of a mask word, given the value of
C    the mask word, and a character variable to build the text in. The length
C    of the resulting text will be returned in ENDPOS.
C
C  declare variables
C
      IMPLICIT NONE
      CHARACTER*(*) LINE
      INTEGER*4 VALUE,ENDPOS
C
      INTEGER*4 I, N, N2, J, ICODE
      CHARACTER*3 MASK_NAM(0:15,2)
      DATA MASK_NAM/'R0','R1','R2','R3','R4','R5','R6','R7','R8','R9',
     +	'R10','R11','AP','FP','SP','PC','R0','R1','R2','R3','R4','R5',
     +	'R6','R7','R8','R9','R10','R11','XX','XX','IV','DV'/
C
      INTEGER*4 LIB$FFS
      EXTERNAL	LIB$FFS
C
C  analyze the bit mask for a procedure entry point, and add text for
C    each set bit
C
      ENDPOS=1
      N=2
      N2=0
      DO I=0,15
	ICODE=LIB$FFS(I,1,VALUE,J)
	IF(ICODE)THEN
	  IF(N2.NE.0)THEN
	    LINE(ENDPOS:ENDPOS)=','
	    ENDPOS=ENDPOS+1
	  ENDIF
	  N2=1
	  LINE(ENDPOS:)=MASK_NAM(I,N)
	  IF(I.EQ.10.OR.I.EQ.11)THEN
	    ENDPOS=ENDPOS+3
	  ELSE
	    ENDPOS=ENDPOS+2
	  ENDIF
	ENDIF
      ENDDO
C
C  close mask
C
      LINE(ENDPOS:ENDPOS)='>'
C
C  exit
C
      RETURN
C
      END
      INTEGER*4 FUNCTION ANALYZE_SYM_REC(TYP,SUBTYP,RECORD,
     +					 OFFSET_VEC,SYM_TBL)
C
C  This procedure analyzes an Object Language record and updates the symbol
C    table and image section descriptor table with the new names found (if
C    any). If an End of Module (EOM) record is read, a zero value is
C    returned to inform the caller that the module end has been reached.
C
      IMPLICIT NONE
C
      BYTE TYP,SUBTYP
      CHARACTER*(*) RECORD
      INTEGER*4 OFFSET_VEC,	SYM_TBL(-1:*)
C
      BYTE	TAB/9/
      CHARACTER*31 S_TMP
      INTEGER*4 I, J, I2, J2, K, K2, TYP_CONV(0:34)
      EXTERNAL DISM__UNKOBJREC,DISM__OBJSYMERR, DISM__SYMTBLOVF
C
      INCLUDE 'DISMISDTBL.INC'
      INCLUDE 'DISMSYMTBL.INC'
C
      DATA TYP_CONV	! convert from VMS DSC$K_DTYPE_xxx to DISM32 bitmasks
     +	/SYM_SUBR,SYM_D_BYT,SYM_D_BYT,SYM_D_WRD,SYM_D_LNG,SYM_D_QUD, ! 0-5
     +	SYM_D_BYT,SYM_D_WRD,SYM_D_LNG,SYM_D_QUD,SYM_D_FLT,SYM_D_DFL, ! 6-11
     +	SYM_D_FLT,SYM_D_DFL,SYM_D_CHR,SYM_D_LSN,SYM_D_LSN,SYM_D_LSN, ! 12-17
     +	SYM_D_TNS,SYM_D_TNS,SYM_D_LSN,SYM_D_PDS,SYM_SUBR,SYM_PROC,   ! 18-23
     +	SYM_D_QUD,SYM_D_OCT,SYM_D_OCT,SYM_D_GFL,SYM_D_HFL,SYM_D_GFL, ! 24-29
     +	SYM_D_HFL,SYM_D_WRD,SYM_D_LNG,SYM_D_LNG,SYM_D_BYT/	     ! 30-34
C
C  select handler for record based upon record type
C
      GOTO (100,1000,2000,3000,4000,5000,6000,7000),TYP+1
C
C  this is a catch-all for undefined record types. it signals a warning.
C
	CALL LIB$SIGNAL(DISM__UNKOBJREC,%VAL(2),%VAL(TYP),%VAL(-1))
	GOTO 9000
C
C  header record: ignore
C
  100	GOTO 9000
C
C  global symbol dictionary record: analyze and update ISD, psect, and symbol
C    tables accordingly
C
 1000	I=1	! initialize for looping through multiple subrecords
	DO WHILE (I.LT.LEN(RECORD))
	  GOTO (1001,1100,1200,1300),SUBTYP+1
C
C  this is a catch-all for undefined GSD subrecord types. it signals a warning.
C
	  CALL LIB$SIGNAL(DISM__UNKOBJREC,%VAL(2),%VAL(TYP),%VAL(SUBTYP))
	  GOTO 9000
C
C  GSD p-sect definition: add this p-sect to the p-sect table
C
 1001	  K=ICHAR(RECORD(I:I))				! get alignment
	  J=0
	  CALL LIB$MOVC3(2,%REF(RECORD(I+1:I+2)),J)	! get flags
	  CALL LIB$MOVC3(4,%REF(RECORD(I+3:I+6)),J2)	! get allocation
	  K2=ICHAR(RECORD(I+7:I+7))			! get name length
	  IF((J.AND.'8'X).NE.0)THEN	! if GPS$V_REL set,
	    CALL WRITE_PSECT_TBL(-1,RECORD(I+8:I+7+K2),J,K,J2)
	  ENDIF
	  I=I+9+K2
	  GOTO 1900
C
C  GSD global symbol specification: read it and store symbol in table; if
C    symbol not defined in table, ignore it
C
 1100	  K2=ICHAR(RECORD(I+1:I+1))
	  IF(((K2.AND.'A'X).EQ.2.OR.
     +	      ((K2.AND.'A'X).EQ.10.AND.
     +	       ICHAR(RECORD(I+3:I+3)).EQ.0)).AND.
     +	     RECORD(I+8:I+20).NE.CHAR(12)//'P1SYSVECTORS')THEN
	    CALL LIB$MOVC3(4,%REF(RECORD(I+4:I+7)),J)
	    J2=ICHAR(RECORD(I:I))
	    IF(OFFSET_VEC.LE.0)THEN
	      K=1
	      DO WHILE (K.LE.SYM_TBL_PTR.AND.
     +			SYM_VAL(K).NE.J)
		K=K+1
	      ENDDO
	      I2=ICHAR(RECORD(I+8:I+8))
	      IF(K.LE.SYM_TBL_PTR.AND.
     +		 (OFFSET_VEC.EQ.0.OR.J.LT.0.OR.J.GE.'40000000'X))THEN
		SYM_NAM(K)=RECORD(I+9:I+8+I2)
		IF((K2.AND.4).NE.0)THEN	! GSY$V_UNI set
		  SYM_TYP(K)=SYM_TYP(K).OR.SYM_TRANSFER
		ENDIF
	      ELSEIF(K.GT.SYM_TBL_PTR.AND.
     +		     (OFFSET_VEC.EQ.0.OR.
     +		      (K2.AND.4).NE.0))THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN
		  CALL LIB$SIGNAL(DISM__SYMTBLOVF)
		ELSE
		  SYM_VAL(SYM_TBL_PTR)=J
		  SYM_TYP(SYM_TBL_PTR)=TYP_CONV(J2)
		  SYM_NAM(SYM_TBL_PTR)=RECORD(I+9:I+8+I2)
		  SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X
		  IF((K2.AND.4).NE.0)THEN
		    SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER
		  ENDIF
		ENDIF
	      ENDIF
	    ELSE
	      K=1
	      DO WHILE (K.LE.SYM_TBL(-1).AND.
     +			SYM_TBL(K).NE.J)
		K=K+1
	      ENDDO
	      IF(K.LE.SYM_TBL(-1))THEN
		I2=ICHAR(RECORD(I+8:I+8))
		SYM_NAM(OFFSET_VEC+K-1)=RECORD(I+9:I+8+I2)
		IF((K2.AND.4).NE.0)THEN
		  SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER
		ENDIF
	      ENDIF
	    ENDIF
	  ENDIF
	  J=ICHAR(RECORD(I+8:I+8))
	  I=I+10+J
	  GOTO 1900
C
C  GSD entry point symbol/mask declaration: same as global symbol spec.
C
 1200	  K2=ICHAR(RECORD(I+1:I+1))
	  IF(((K2.AND.'A'X).EQ.2.OR.
     +	      ((K2.AND.'A'X).EQ.10.AND.
     +	       ICHAR(RECORD(I+3:I+3)).EQ.0)).AND.
     +	     RECORD(I+10:I+22).NE.CHAR(12)//'P1SYSVECTORS')THEN
	    CALL LIB$MOVC3(4,%REF(RECORD(I+4:I+7)),J)
	    IF(OFFSET_VEC.LE.0)THEN
	      K=1
	      DO WHILE (K.LE.SYM_TBL_PTR.AND.
     +			SYM_VAL(K).NE.J)
		K=K+1
	      ENDDO
	      I2=ICHAR(RECORD(I+10:I+10))
	      IF(K.LE.SYM_TBL_PTR.AND.
     +		 (OFFSET_VEC.EQ.0.OR.J.LT.0.OR.J.GE.'40000000'X))THEN
		SYM_NAM(K)=RECORD(I+11:I+10+I2)
	      ELSEIF(K.GT.SYM_TBL_PTR.AND.
     +		     OFFSET_VEC.EQ.0)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN
		  CALL LIB$SIGNAL(DISM__SYMTBLOVF)
		ELSE
		  SYM_VAL(SYM_TBL_PTR)=J
		  SYM_TYP(SYM_TBL_PTR)=SYM_PROC
		  SYM_NAM(SYM_TBL_PTR)=RECORD(I+11:I+10+I2)
		  SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X
		  IF((K2.AND.4).NE.0)THEN
		    SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER
		  ENDIF
		ENDIF
	      ENDIF
	    ELSE
	      K=1
	      DO WHILE (K.LE.SYM_TBL(-1).AND.
     +			SYM_TBL(K).NE.J)
		K=K+1
	      ENDDO
	      IF(K.LE.SYM_TBL(-1))THEN
		I2=ICHAR(RECORD(I+10:I+10))
		SYM_NAM(OFFSET_VEC+K-1)=RECORD(I+11:I+10+I2)
		IF((K2.AND.4).NE.0)THEN
		  SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER
		ENDIF
	      ENDIF
	    ENDIF
	  ENDIF
	  J=ICHAR(RECORD(I+10:I+10))
	  I=I+12+J
	  GOTO 1900
C
C  GSD procedure definition: same as global symbol spec, except argument
C    types can be used (maybe) to make up symbols for offsets from AP.
C
 1300	  K2=ICHAR(RECORD(I+1:I+1))
	  IF(((K2.AND.'A'X).EQ.2.OR.
     +	      ((K2.AND.'A'X).EQ.10.AND.
     +	       ICHAR(RECORD(I+3:I+3)).EQ.0)).AND.
     +	     RECORD(I+10:I+22).NE.CHAR(12)//'P1SYSVECTORS')THEN
	    CALL LIB$MOVC3(4,%REF(RECORD(I+4:I+7)),J)
	    J2=ICHAR(RECORD(I:I))
	    IF(OFFSET_VEC.LE.0)THEN
	      K=1
	      DO WHILE (K.LE.SYM_TBL_PTR.AND.
     +			SYM_VAL(K).NE.J)
		K=K+1
	      ENDDO
	      I2=ICHAR(RECORD(I+10:I+10))
	      IF(K.LE.SYM_TBL_PTR.AND.
     +		 (OFFSET_VEC.EQ.0.OR.J.LT.0.OR.J.GE.'40000000'X))THEN
		SYM_NAM(K)=RECORD(I+11:I+10+I2)
	      ELSEIF(K.GT.SYM_TBL_PTR.AND.
     +		     OFFSET_VEC.EQ.0)THEN
		SYM_TBL_PTR=SYM_TBL_PTR+1
		IF(SYM_TBL_PTR.GT.SYM_TBL_SIZE)THEN
		  CALL LIB$SIGNAL(DISM__SYMTBLOVF)
		ELSE
		  SYM_VAL(SYM_TBL_PTR)=J
		  SYM_TYP(SYM_TBL_PTR)=SYM_PROC
		  SYM_NAM(SYM_TBL_PTR)=RECORD(I+11:I+10+I2)
		  SYM_VAL(SYM_TBL_PTR+1)='7FFFFFFF'X
		  IF((K2.AND.4).NE.0)THEN
		    SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER
		  ENDIF
		ENDIF
	      ENDIF
	    ELSE
	      K=1
	      DO WHILE (K.LE.SYM_TBL(-1).AND.
     +			SYM_TBL(K).NE.J)
		K=K+1
	      ENDDO
	      IF(K.LE.SYM_TBL(-1))THEN
		I2=ICHAR(RECORD(I+10:I+10))
		SYM_NAM(OFFSET_VEC+K-1)=RECORD(I+11:I+10+I2)
		IF((K2.AND.4).NE.0)THEN
		  SYM_TYP(SYM_TBL_PTR)=SYM_TYP(SYM_TBL_PTR).OR.SYM_TRANSFER
		ENDIF
	      ENDIF
	    ENDIF
	  ENDIF
C******************
	  J=ICHAR(RECORD(I+10:I+10))
	  I=I+12+J
C******************
	  GOTO 1900
C
 1900	  IF(I.LT.LEN(RECORD))THEN
	    SUBTYP=ICHAR(RECORD(I-1:I-1))
	  ENDIF
	ENDDO
	GOTO 9000
C
C  text information and relocation record: ignore
C
 2000	GOTO 9000
C
C  end of module record: check error field, then exit
C
 3000	IF(SUBTYP.NE.0)THEN
	  CALL LIB$SIGNAL(DISM__OBJSYMERR,%VAL(1),%VAL(SUBTYP))
	ENDIF
	ANALYZE_SYM_REC=1
	GOTO 9999
C
C  debug information record: ignore
C
 4000	GOTO 9000
C
C  traceback information record: ignore
C
 5000	GOTO 9000
C
C  link option specification record: add .LINK pseudo-op to .MAR file
C
 6000	J2=0
	CALL LIB$MOVC3(2,%REF(RECORD(1:2)),J2)
	K=0
	CALL LIB$MOVC3(2,%REF(RECORD(3:4)),K)
	GOTO (6100,6100,6200,6300,6400),SUBTYP+1
C
C  this is a catch-all for undefined LNK subrecord types. it signals a warning.
C
	  CALL LIB$SIGNAL(DISM__UNKOBJREC,%VAL(2),%VAL(TYP),%VAL(SUBTYP))
	  GOTO 9000
C
C  LNK object or shareable image library specification: write out file spec
C
 6100	  WRITE(6,9601) TAB, TAB, RECORD(5:4+K)
 9601	  FORMAT(A1,'.LINK',A1,'"',A,'"/LIBRARY')
	  GOTO 9000
C
C  LNK object library with include list specification: write out file spec
C
 6200	  WRITE(6,9620) TAB, TAB, RECORD(5:4+K)
 9620	  FORMAT(A1,'.LINK',A1,'"',A,'"/INCLUDE')
	  GOTO 9000
C
C  LNK object file specification: write out file spec
C
 6300	  S_TMP=' '
	  J=0
	  IF(J2)THEN
	    S_TMP='/SELECTIVE_SEARCH'
	    J=17
	  ENDIF
	  WRITE(6,9630) TAB, TAB, RECORD(5:4+K), S_TMP(1:J)
 9630	  FORMAT(A1,'.LINK',A1,'"',A,'"',A)
	  GOTO 9000
C
C  LNK shareable image specification: write out file spec
C
 6400	  WRITE(6,9640) TAB, TAB, RECORD(5:4+K)
 9640	  FORMAT(A1,'.LINK',A1,'"',A,'"/SHAREABLE')
	  GOTO 9000
C
C  end of module (word psect) record: check error field, then exit
C
 7000	IF(SUBTYP.NE.0)THEN
	  CALL LIB$SIGNAL(DISM__OBJSYMERR,%VAL(1),%VAL(SUBTYP))
	ENDIF
	ANALYZE_SYM_REC=1
	GOTO 9999
C
C  return successfully
C
 9000 ANALYZE_SYM_REC=0
 9999 RETURN
C
      END
      INTEGER*4 FUNCTION CONVERT_F_FLOAT(X,STR,LN)
C
      IMPLICIT NONE
      CHARACTER*(*) STR
      INTEGER*2 LN
      REAL*4	X
C
      INTEGER*4 FOR$CVT_D_TG
      EXTERNAL	LIB$SIG_TO_RET,	FOR$CVT_D_TG
C
      CALL LIB$ESTABLISH(LIB$SIG_TO_RET)
      LN=0
      STR=' '
      CONVERT_F_FLOAT=FOR$CVT_D_TG(
     +		DBLE(X),STR,%VAL(7),%VAL(0),%VAL(2),%VAL(2))
      CALL STR$TRIM(STR,STR,LN)
      RETURN
C
      END
      INTEGER*4 FUNCTION CONVERT_D_FLOAT(X,STR,LN)
C
      IMPLICIT NONE
      CHARACTER*(*) STR
      INTEGER*2 LN
      REAL*8	X
C
      INTEGER*4 FOR$CVT_D_TG
      EXTERNAL	LIB$SIG_TO_RET,	FOR$CVT_D_TG
C
      CALL LIB$ESTABLISH(LIB$SIG_TO_RET)
      LN=0
      STR=' '
      CONVERT_D_FLOAT=FOR$CVT_D_TG(
     +		X,STR,%VAL(17),%VAL(0),%VAL(2),%VAL(2))
      CALL STR$TRIM(STR,STR,LN)
      RETURN
C
      END
      OPTIONS /G_FLOATING
      INTEGER*4 FUNCTION CONVERT_G_FLOAT(X,STR,LN)
C
      IMPLICIT NONE
      CHARACTER*(*) STR
      INTEGER*2 LN
      REAL*8	X
C
      INTEGER*4 FOR$CVT_G_TG
      EXTERNAL	LIB$SIG_TO_RET,	FOR$CVT_G_TG
C
      CALL LIB$ESTABLISH(LIB$SIG_TO_RET)
      LN=0
      STR=' '
      CONVERT_G_FLOAT=FOR$CVT_G_TG(
     +			X,STR,%VAL(16),%VAL(0),%VAL(2),%VAL(2))
      CALL STR$TRIM(STR,STR,LN)
      RETURN
C
      END
      INTEGER*4 FUNCTION CONVERT_H_FLOAT(X,STR,LN)
C
      IMPLICIT NONE
      CHARACTER*(*) STR
      INTEGER*2 LN
      REAL*16	X
C
      INTEGER*4 FOR$CVT_H_TG
      EXTERNAL	LIB$SIG_TO_RET,	FOR$CVT_H_TG
C
      CALL LIB$ESTABLISH(LIB$SIG_TO_RET)
      LN=0
      STR=' '
      CONVERT_H_FLOAT=FOR$CVT_H_TG(
     +			X,STR,%VAL(33),%VAL(0),%VAL(4),%VAL(2))
      CALL STR$TRIM(STR,STR,LN)
      RETURN
C
      END
      SUBROUTINE BUILD_IO_LIST(IO_MASK,STR,LN,NUM)
C
C  this procedure converts an FDT I/O function bit-mask into a string of
C    combined I/O function names
C
      IMPLICIT NONE
      CHARACTER*(*) STR
      INTEGER*2 LN, NUM
      INTEGER*4 IO_MASK(2)
C
      CHARACTER*11 IOSYM(0:63)
      INTEGER*2 IOLEN(0:63)
      INTEGER*4 I
      DATA IOSYM/'NOP','LOADMCODE','STARTMPROC','STOP','INITIALIZE',
     +		 'RELEASE','ERASETAPE','QSTOP','PACKACK','SPACERECORD',
     +		 'WRITECHECK','WRITEPBLK','READPBLK','WRITEHEAD',
     +		 'READHEAD','WRITETRACKD','READTRACKD','AVAILABLE',
     +		 '**^X12**','**^X13**','**^X14**','DSE','REREADN',
     +		 'REREADP','WRITECHECKH','READPRESET','SETCHAR',
     +		 'SENSECHAR','WRITEMARK','DIAGNOSE','FORMAT','PHYSICAL',
     +		 'WRITELBLK','READLBLK','REWINDOFF','SETMODE','REWIND',
     +		 'SKIPFILE','SKIPRECORD','SENSEMODE','WRITEOF',
     +		 '**^X29**','**^X2A**','**^X2B**','**^X2C**','**^X2D**',
     +		 '**^X2E**','LOGICAL','WRITEVBLK','READVBLK','ACCESS',
     +		 'CREATE','DEACCESS','DELETE','MODIFY','READPROMPT',
     +		 'ACPCONTROL','MOUNT','TTYREADALL','TTYREADPALL',
     +		 'CONINTREAD','CONINTWRITE','**^X3E**','VIRTUAL'/
      DATA IOLEN/3,9,10,4,10,7,9,5,7,11,10,9,8,9,8,11,10,9,8,8,8,3,7,
     +		 7,11,10,7,9,9,8,6,8,
     +		 9,8,9,7,6,8,10,9,7,8,8,8,8,8,8,7,
     +		 9,8,6,6,8,6,6,10,10,5,10,11,10,11,8,7/
C
      STR='<'
      LN=0
      NUM=0
      DO I=0,31
	IF((IO_MASK(1).AND.JISHFT(1,I)).NE.0)THEN
	  STR(LN+2:)=IOSYM(I)
	  LN=LN+IOLEN(I)+2
	  STR(LN:LN)=','
	  NUM=NUM+1
	ENDIF
      ENDDO
      DO I=0,31
	IF((IO_MASK(2).AND.JISHFT(1,I)).NE.0)THEN
	  STR(LN+2:)=IOSYM(I+32)
	  LN=LN+IOLEN(I+32)+2
	  STR(LN:LN)=','
	  NUM=NUM+1
	ENDIF
      ENDDO
      LN=MAX(LN,2)
      STR(LN:LN)='>'
C
      RETURN
C
      END
      SUBROUTINE WRITE_FORMAT_REPEAT(ADDR,VFEM)
C
      IMPLICIT NONE
      BYTE	VFEM
      INTEGER*4 ADDR
C
      INTEGER*4 VAL
      CHARACTER*1 TAB /9/
C
      IF((VFEM.AND.'80'X).NE.0)THEN	! if VFEM RC bit set
	CALL COPY_LONG(ADDR,VAL)	! get VFE address
	ADDR=ADDR+4
	VAL=VAL+ADDR
	WRITE(2,
     +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE repeat count'')')
     +				TAB, TAB, VAL, TAB, TAB
      ELSE
	VAL=0
	IF((VFEM.AND.'3'X).EQ.0)THEN
	  WRITE(2,'(4A1,''; default repeat count=1'')')
     +				TAB, TAB, TAB, TAB
	ELSEIF((VFEM.AND.'3'X).EQ.1)THEN
	  CALL COPY_BYTE(ADDR,VAL)
	  ADDR=ADDR+1
	  WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; repeat count'')')
     +				TAB, TAB, VAL, TAB, TAB
	ELSEIF((VFEM.AND.'3'X).EQ.2)THEN
	  CALL COPY_WORD(ADDR,VAL)
	  ADDR=ADDR+2
	  WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; repeat count'')')
     +				TAB, TAB, VAL, TAB, TAB
	ENDIF
      ENDIF
C
      RETURN
C
      END
      SUBROUTINE WRITE_FORMAT_WIDTH(ADDR,VFEM)
C
      IMPLICIT NONE
      BYTE	VFEM
      INTEGER*4 ADDR
C
      INTEGER*4 VAL
      CHARACTER*1 TAB /9/
C
      IF((VFEM.AND.'40'X).NE.0)THEN	! if VFEM W bit set
	CALL COPY_LONG(ADDR,VAL)	! get VFE address
	ADDR=ADDR+4
	VAL=VAL+ADDR
	WRITE(2,'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE width'')')
     +				TAB, TAB, VAL, TAB, TAB
      ELSE
	VAL=0
	IF((VFEM.AND.'4'X).EQ.0)THEN
	  CALL COPY_BYTE(ADDR,VAL)
	  ADDR=ADDR+1
	  WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; field width'')')
     +				TAB, TAB, VAL, TAB, TAB
	ELSE
	  CALL COPY_WORD(ADDR,VAL)
	  ADDR=ADDR+2
	  WRITE(2,'(A1,5H.WORD,A1,I5,2A1,''; field width'')')
     +				TAB, TAB, VAL, TAB, TAB
	ENDIF
      ENDIF
C
      RETURN
C
      END
      SUBROUTINE WRITE_FORMAT_MANTISSA(ADDR,VFEM)
C
      IMPLICIT NONE
      BYTE	VFEM
      INTEGER*4 ADDR
C
      INTEGER*4 VAL
      CHARACTER*1 TAB /9/
C
      IF((VFEM.AND.'20'X).NE.0)THEN	! if VFEM D bit set
	CALL COPY_LONG(ADDR,VAL)	! get VFE address
	ADDR=ADDR+4
	VAL=VAL+ADDR
	WRITE(2,
     +'(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,''; VFE decimal width'')')
     +				TAB, TAB, VAL, TAB, TAB
      ELSE
	VAL=0
	CALL COPY_BYTE(ADDR,VAL)
	ADDR=ADDR+1
	WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; decimal width'')')
     +				TAB, TAB, VAL, TAB, TAB
      ENDIF
C
      RETURN
C
      END
      SUBROUTINE WRITE_FORMAT_EXPONENT(ADDR,VFEM)
C
      IMPLICIT NONE
      BYTE	VFEM
      INTEGER*4 ADDR
C
      INTEGER*4 VAL
      CHARACTER*1 TAB /9/
C
      IF((VFEM.AND.'10'X).NE.0)THEN	! if VFEM E bit set
	CALL COPY_LONG(ADDR,VAL)	! get VFE address
	ADDR=ADDR+4
	VAL=VAL+ADDR
	WRITE(2,9000) TAB, TAB, VAL, TAB, TAB
 9000	FORMAT(A1,5H.LONG,A1,3HLC$,Z8.8,6H-<.+4>,2A1,
     +			'; VFE exponent width')
      ELSE
	VAL=0
	CALL COPY_BYTE(ADDR,VAL)
	ADDR=ADDR+1
	WRITE(2,'(A1,5H.BYTE,A1,I3,2A1,''; exponent width'')')
     +				TAB, TAB, VAL, TAB, TAB
      ENDIF
C
      RETURN
C
      END
      SUBROUTINE WRITE_PSECT_TBL(BASE,NAME,FLAGS,ALIGN,ALLOC)
C
      IMPLICIT NONE
C
      BYTE	ALIGN
      CHARACTER*(*) NAME
      INTEGER*2 FLAGS
      INTEGER*4 BASE, ALLOC
C
      INCLUDE 'DISMISDTBL.INC'
C
      INTEGER*4 I, J
C
      IF(BASE.NE.-1)THEN
	I=1
	DO WHILE (I.LE.ISD_NUM.AND.
     +		  (BASE.LT.ISD_BASEVA(I).OR.
     +		   BASE.GT.ISD_PGEND(I)))
	  I=I+1
	ENDDO
	IF(I.LE.ISD_NUM)THEN
	  J=1
	  DO WHILE (J.LE.PSECT_NUM.AND.
     +		    (PSECT_ISD(J).NE.I.OR.
     +		     PSECT_BASEADR(J).GE.BASE))
	    J=J+1
	  ENDDO
	ENDIF
      ELSEIF(NAME.NE.' ')THEN
	
      ENDIF
C
      RETURN
C
      END
