C	Version 'V04-000'
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1978, 1980, 1982, 1984 BY				    *
C*  DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS.		    *
C*  ALL RIGHTS RESERVED.						    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED   *
C*  ONLY IN  ACCORDANCE WITH  THE  TERMS  OF  SUCH  LICENSE  AND WITH THE   *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR  ANY  OTHER   *
C*  COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY   *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE IS  HEREBY   *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS  SUBJECT TO CHANGE WITHOUT NOTICE   *
C*  AND  SHOULD  NOT  BE  CONSTRUED AS  A COMMITMENT BY DIGITAL EQUIPMENT   *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE  OR  RELIABILITY OF ITS   *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C* 									    *
C*									    *
C****************************************************************************
C
C	REVISION HISTORY:
C		23-03-77	CP	IF OUTPUTTING TO TMP FILE, JUST OUTPUT
C					EACH LINE UNTIL THE END OF THE CONSTANT
C					DEFINITION, THEN RETURN.
C
C		04-04-77	TC	SPLIT LABEL 120 INTO 121 AND 122
C					WHICH ALLOWS LOOPING BACK TO TWO
C					ALTERNATE POINTS (65 AND 70)

	SUBROUTINE PCONST

C	THIS ROUTINE IS CALLED WHEN A LINE HAS BEEN RECOGNIZED
C	AS A CONSTANT DEFINITION. THE IMPLICIT ARGUMENT
C	INPTR IS THE OFFSET TO THE NEXT CHARACTER IN THE INPUT LINE.

C	PCONST FIRST DETERMINES WHETHER THIS IS A SINGLE CONSTANT
C	DEFINITION OR A LIST OF CONSTANT DEFINITIONS. IF A SINGLE
C	CONSTANT IS BEING DEFINED, THE ROUTINE PSCONS IS CALLED TO
C	PROCESS THE DEFINITION. 

C	OTHERWISE, PCONST COLLECTS THE CONSTANT PREFIX NAME, THE
C	TAG, THE BASE, AND THE INCREMENT FOR THE LIST. THEN IT
C	COLLECTS A CONSTANT DEFINITION AT A TIME. EACH CONSTANT
C	DEFINITION CAN HAVE A NAME AND A VALUE. VALUES CAN
C	BE ARBITRARILY COMPLEX EXPRESSIONS. EACH CONSTANT IS
C	PROCESSED AND OUTPUT.

C	WHEN A SINGLE LEADING RIGHT ANGLE BRACKET IS RECOGNIZED AFTER
C	A NUMBER OF CONSTANT DEFINITIONS IN A LIST, THE PROCESSING
C	OF THE CONSTANT LIST IS COMPLETE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER PTR, CLNCON


C	THE CONSTANT CAN BE DEFINED WITH A "C" OR A "K". THEY
C	ARE SEMANTICALLY EQUIVALENT DEFINITIONS, BUT THE DEFAULT TAG
C	NAMES ARE DEPENDENT ON THE FIRST TOKEN IN THE LINE,
C	NAMELY "C" OR "K".

	TAGNAM (3) = TOKSTG (2)

C	SEE WHETHER THE NEXT TOKEN IS THE NAME OF A CONSTANT OR
C	A LEFT ANGLE BRACKET. THE LATTER INDICATES THAT THIS IS
C	THE BEGINNING OF A CONSTANT DEFINITION LIST.

	CALL GETTOK
	IF (DEBUG) TYPE 300, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
300	FORMAT (' ',90A1)
	IF (DEBUG) TYPE 310, TOKTYP
310	FORMAT (' TOKTYP IS ',I3)
	IF (TOKTYP .EQ. LANGLE) GOTO 10
	IF (TMPOUT) GOTO 160
	CALL PSCONS
	RETURN

C	THIS IS THE DEFINITION OF A CONSTANT LIST. COLLECT THE
C	PARAMETERS FOR THE LIST. FIRST INITIALIZE SOME VARIABLES.

10	IF (.NOT. TMPOUT) GOTO 15
	CALL OUT2LN
	GOTO 70

15	CALL MOVSTG (TAGNAM, CONTAG)
	CALL MOVSTG (PRENAM, CONPRE)
	MRBASE (1) = 1
	MRBASE (2) = '0'
	CALL MOVSTG (MRBASE, BLBASE)
	MRINCR (1) = 1
	MRINCR (2) = '1'
	CALL MOVSTG (MRINCR, BLINCR)

C	LOOK FOR A PREFIX ARGUMENT. IF PRESENT, THIS PREFIX REPLACES
C	THE $STRUCT PREFIX FOR THE DURATION OF THE CONSTANT LIST.

	CALL GETTOK
	IF (DEBUG) TYPE 300, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 20
	CALL MOVSTG (TOKSTG, CONPRE)
	CALL GETTOK
	IF (DEBUG) TYPE 300, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	NAME, IF ANY, IS SAVED. LOOK FOR A TAG FIELD. IF ABSENT,
C	THE DEFAULT TAG FIELD IS '$C_' OR '$K_' AS STORED EARLIER AT
C	THE START OF THIS ROUTINE. ANY ALPHA STRING FOUND AS
C	THE SECOND ARGUMENT REPLACES THE DEFAULT TAG.

20	IF (DEBUG) TYPE 310, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 50
	CALL GETTOK
	IF (DEBUG) TYPE 300, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 30
	CALL MOVSTG (TOKSTG, CONTAG)
	CALL GETTOK
	IF (DEBUG) TYPE 300, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	TAG NAME IS SAVED. SEE IF A BASE ARGUMENT IS SPECIFIED.
C	BASE ARGUMENT CAN BE AN EXPRESSION.

30	IF (DEBUG) TYPE 310, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 50
	PTR = INPTR
	IF (DEBUG) TYPE 520, PTR, INBUF (INPTR)
	CALL GETEXP (INPTR)
	IF (DEBUG) TYPE 530, INPTR, INBUF (INPTR)
	IF (INBUF (INPTR) .EQ. ',') GOTO 45
	IF ((INBUF (INPTR) .EQ. ' ') .OR.
	1	(INBUF (INPTR) .EQ. '	') .OR.
	2	(INBUF (INPTR) .EQ. EOL) .OR.
	3	(INBUF (INPTR) .EQ. ';')) GOTO 60
	INBUF (PTR - 1) = INPTR - PTR + 1
	CALL MOVSTG (INBUF (PTR - 1), CVALUE)
	CALL CVTEXP (CVALUE, BLBASE, MRBASE)

C	BASE EXPRESSION, IF ANY, IS SAVED. NOW RETRIEVE
C	THE INCREMENT ARGUMENT. THIS CAN ALSO BE AN EXPRESSION.

	INPTR = NEXTNB (INPTR)
	IF (INBUF (INPTR) .NE. ',') GOTO 50
45	PTR = INPTR + 1
	INPTR = INPTR + 1
	IF (DEBUG) TYPE 520, PTR, INBUF (INPTR)
	CALL GETEXP (INPTR)
	IF (DEBUG) TYPE 530, INPTR, INBUF (INPTR)
	IF ((INBUF (INPTR) .EQ. ',') .OR.
	1	(INBUF (INPTR) .EQ. ' ') .OR. 
	2	(INBUF (INPTR) .EQ. '	') .OR.
	3	(INBUF (INPTR) .EQ. EOL) .OR.
	4	(INBUF (INPTR) .EQ. ';')) GOTO 60
	INBUF (PTR - 1) = INPTR - PTR + 1
	CALL MOVSTG (INBUF (PTR - 1), CVALUE)
	CALL CVTEXP (CVALUE, BLINCR, MRINCR)
	GOTO 60

C	THE OFFSET INTO THE INPUT BUFFER IS SLIGHTLY OFF BECAUSE
C	SOME OPTIONAL TRAILING ARGUMENTS WERE OMITTED. BACK UP
C	THE INPUT LINE OFFSET TO THE CORRECT SPOT.

50	INPTR = LASTNB (INPTR - 2)

C	ARGUMENTS ARE ALL COLLECTED. NOW OUTPUT LINES TO BLISS AND
C	MARS.

60	IF (DEBUG) TYPE 400, PTR, INBUF (INPTR)
400	FORMAT (' COMMENT STARTS AT ',I3,' CHAR IS ',A1)
	LINTYP = CONST
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)

C	EACH CONSTANT NAME DEFINITION WITHIN A LIST STARTS WITH A COMMA

65	CLNCON = 0
	CONEXP = .FALSE.

C	NOW COLLECT THE CONSTANT NAME DEFINITIONS ONE AT A TIME UNTIL
C	THE END OF THE LIST IS REACHED.

70	CALL GETLIN
	IF (ENDFIL) RETURN

C	GET A TOKEN AND SEE WHETHER IT IS A RIGHT ANGLE BRACKET
C	OR AN ALPHA STRING. THE FORMER MEANS THAT THE CONSTANT
C	LIST IS FINISHED. THE LATTER MEANS THAT THIS IS ANOTHER
C	CONSTANT NAME DEFINITION.

	IF ((.NOT. ENDEXP) .AND. (CONEXP)) GOTO 77
	CALL GETTOK
	IF (DEBUG) TYPE 300, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (DEBUG) TYPE 310, TOKTYP
	IF (TOKTYP .EQ. RANGLE) GOTO 150
	IF (TMPOUT) GOTO 140
	IF ((TOKTYP .EQ. EOL) .OR. (TOKTYP .EQ. SEMI)) GOTO 110
77	LINTYP = CONSTN

C	THIS IS THE DECLARATION OF A CONSTANT NAME.
C	NOW INITIALIZE SOME VARIABLES.

80	IF (TMPOUT) GOTO 140
	ENDEXP = .FALSE.
	CVALUE (1) = 0
	BVALUE (1) = 0
	MVALUE (1) = 0
	FLDNAM (1) = 0

	IF (CONEXP) GOTO 86
	IF (TOKTYP .NE. ALPHA) GOTO 220

C	THIS IS A NAME TO DEFINE. SAVE IT.

	CALL MOVSTG (TOKSTG, FLDNAM)
	CALL GETTOK
	IF (DEBUG) TYPE 300, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	NOW SEE IF THERE IS A VALUE FIELD.

	IF (DEBUG) TYPE 310, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 90
	GOTO 89

C	IF YOU GET HERE, THIS IS A CONTINUATION LINE FROM AN
C	EXPRESSION. SKIP OVER THE BLANKS AND TABS BEFORE TRYING
C	TO GET THE EXPRESSION.

86	DO 87 INPTR = 2, INBUF (1) + 1
	IF ((INBUF (INPTR) .NE. ' ') .AND.
	1	(INBUF (INPTR) .NE. '	')) GOTO 89
87	CONTINUE

C	ARRIVAL HERE IS AN ERROR

	GOTO 230

C	THE NAME HAS BEEN SAVED. THE NEXT ARGUMENT IS AN OPTIONAL
C	EXPRESSION. IF IT IS OF ZERO LENGTH, THE ARGUMENT DEFAULTS
C	TO THE VALUE OF ONE. SAVE THE LINE POINTER TO CHECK FOR ZERO
C	LENGTH LATER.

89	PTR = INPTR
	IF (DEBUG) TYPE 520, PTR, INBUF (INPTR)
520	FORMAT (' EXPRESSION STARTS AT OFFSET ',I3,' CHAR IS ',A1)
	CALL GETEXP (INPTR)
	IF (DEBUG) TYPE 530, INPTR, INBUF (INPTR)
530	FORMAT (' EXPRESSION STOPS AT OFFSET ',I3,' CHAR IS ',A1)
	IF ((INBUF (INPTR) .EQ. ',') .OR.
	1	(INBUF (INPTR) .EQ. ' ') .OR.
	2	(INBUF (INPTR) .EQ. '	') .OR.
	3	(INBUF (INPTR) .EQ. ';') .OR.
	4	(INBUF (INPTR) .EQ. EOL)) GOTO 95
	IF (INBUF (INPTR) .EQ. '-') CONEXP = .TRUE.
	IF ((INBUF (INPTR) .NE. '-') .AND.
	1	(CONEXP)) ENDEXP = .TRUE.

C	AN EXPRESSION WAS FOUND, COMPUTE ITS LENGTH.

	IF (DEBUG) TYPE 540, PTR, INPTR
540	FORMAT (' START IS ',I3,' END IS 'I3)
	INBUF (PTR - 1) = INPTR - PTR + 1
	IF (DEBUG) TYPE 550, INBUF (PTR - 1)
550	FORMAT (' COUNT IS ',I3)
	IF (DEBUG) TYPE 300, (INBUF (I), I = PTR, INBUF (PTR - 1) + 1)

C	NOW SAVE THE EXPRESSION STRING AND CONVERT IT TO MARS AND
C	BLISS.

	CALL MOVSTG (INBUF (PTR - 1), CVALUE)
	CALL CVTEXP (CVALUE, BVALUE, MVALUE)

C	THE EXPRESSION IS PROCESSED.
C	SAVE THE REST OF THE LINE AND GO LOOK FOR ANOTHER
C	CONSTANT DEFINITION.

	GOTO 95

C	THE OFFSET INTO THE INPUT LINE IS OFF BY A FEW CHARACTERS BECAUSE
C	THE EXPRESSION ARGUMENT WAS OMITTED. BACK UP TO THE CORRECT
C	POSITION.

90	INPTR = LASTNB (INPTR - 2)

C	COMMA WAS GIVEN AFTER NAME, BUT NO EXPRESSION WAS GIVEN.
C	ADJUST INPTR.

95	INBUF (INPTR) = INBUF (1) - INPTR + 1
100	CALL GETREM (INPTR)
	IF ((CLNCON .LT. 10) .OR. (CONEXP)) GOTO 121

C	10 CONSTANT NAMES HAVE BEEN DEFINED. CLOSE OUT THIS
C	CONSTANT DEFINITION LIST, AND START ANOTHER.

	CALL OUTCNL
	GOTO 122

C	THIS IS A BLANK OR COMMENT ONLY LINE.
C	OUTPUT IT AND GO BACK FOR ANOTHER.

110	CALL OUTBCL
	GOTO 70

C	OUTPUT THE CURRENT LINE THEN GO GET ANOTHER.

121	CALL MDOUTL(PTR)
	CALL BDOUTL(PTR)
	CLNCON = CLNCON+1
	IF (ENDEXP) CONEXP = .FALSE.
	GOTO 70

122	CALL MDOUTL(PTR)
	CALL BDOUTL(PTR)
	CLNCON = CLNCON+1
	IF (ENDEXP) CONEXP = .FALSE.
	GOTO 65

140	CALL OUT2LN
	GOTO 70

C	OUTPUT THE FINAL CLOSING OF THE CONSTANT DEFINITION LIST.

150	IF (TMPOUT) GOTO 160
	LINTYP = CONSTE
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	RETURN

160	CALL OUT2LN
	RETURN

C	ERROR REPORTING

200	TYPE 2000
2000	FORMAT (' INVALID BASE ARGUMENT IN CONSTANT LIST')
	RETURN

210	TYPE 2100
2100	FORMAT (' INVALID INCREMENT ARGUMENT IN CONSTANT LIST')
	RETURN

220	TYPE 2200
2200	FORMAT (' INVALID NAME IN CONSTANT DEFINITION')
	RETURN

230	TYPE 2300
2300	FORMAT (' INVALID CONTINUED EXPRESSION IN CONSTANT LIST')
	RETURN

	END

	SUBROUTINE PSCONS

C	THIS ROUTINE PROCESSES A SINGLE CONSTANT DEFINITION THAT
C	IS NOT PART OF A LIST. THE CONSTANT DEFINITION HAS TWO
C	ARGUMENTS, BOTH OF WHICH ARE REQUIRED -- THE NAME AND THE
C	VALUE. THE VALUE IS AN ARBITRARILY COMPLICATED EXPRESSION.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER PTR

C	INITIALIZE THE LINE TYPE. REMEMBER THAT THE TAG NAME WAS
C	INITIALIZED IN THE ROUTINE PCONST, WHICH CALLED THIS ROUTINE.

	LINTYP = SCONST

C	NOW LOOK AT THE TYPE OF TOKEN THAT HAS BEEN FOUND BY THE
C	CALLING ROUTINE, PCONST.

	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
500	FORMAT (' ',90A1)
	IF (DEBUG) TYPE 510, TOKTYP
510	FORMAT (' TOKTYP IS ',I3)
	IF (TOKTYP .NE. ALPHA) GOTO 100
	CALL MOVSTG (TOKSTG, FLDNAM)
	CALL GETTOK
	IF (DEBUG) TYPE 510, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 110

C	THE NAME HAS BEEN SAVED. THE NEXT ARGUMENT IS AN EXPRESSION.
C	THE OFFSET TO THE BEGINNING OF THE EXPRESSION IS SAVED
C	TO LATER DETERMINE WHETHER THE EXPRESSION IS OF NON-ZERO
C	LENGTH.

	PTR = INPTR
	IF (DEBUG) TYPE 330, PTR, INBUF (INPTR)
330	FORMAT (' EXPRESSION STARTS AT OFFSET ',I3,' CHAR IS ',A1)
	CALL GETEXP (INPTR)
	IF (DEBUG) TYPE 340, INPTR, INBUF (INPTR)
340	FORMAT (' EXPRESSION STOPS AT OFFSET ',I3,' CHAR IS ',A1)
	IF (INBUF (INPTR) .EQ. ',') GOTO 110

C	AN EXPRESSION WAS FOUND. COMPUTE THE LENGTH OF THE EXPRESSION.

	INBUF (PTR - 1) = INPTR - PTR + 1
	IF (DEBUG) TYPE 500, (INBUF (I), I = PTR, INBUF (PTR - 1) + 1)

C	NOW SAVE THE EXPRESSION STRING AND CONVERT IT TO MARS
C	AND BLISS.

	CALL MOVSTG (INBUF (PTR - 1), CVALUE)
	CALL CVTEXP (CVALUE, BVALUE, MVALUE)
	INPTR = INPTR + 1

C	THE EXPRESSION IS PROCESSED. NOW OUTPUT THE DEFINITION
C	TO THE MARS AND BLISS TRANSLATED OUTPUT FILES.

	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	RETURN

C	ERROR REPORTING

100	TYPE 1000 
1000	FORMAT (' NAME MISSING IN CONSTANT DEFINITION')
	RETURN

110	TYPE 1100
1100	FORMAT (' EXPRESSION MISSING IN CONSTANT DEFINITION')
	RETURN
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C	REVISION HISTORY:
C		22-03-77	CP	IF MARK IN A NEGATIVE CONTEXT, JUST
C					SAVE THE CURRENT NEGATIVE COUNT, AND
C					OUTPUT THE LINE TO THE TMP FILE.
C
C		19-04-77	TC	USE THE ADDITIONAL CONTEX VARIABLE
C					DISCUSSED IN IN:MDL32CMN.CMN

	SUBROUTINE PMARK

C	SAVES THE CONTEXT OF THE CURRENT STRUCTURE DECLARATION SO
C	THAT THIS CONTEXT CAN BE RESTORED AT SOME LATER POINT.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER INDEX

	CALL GETTOK
	IF (TOKTYP .NE. NUMBER) GOTO 1000
	INDEX = INTVAL (TOKSTG)
	IF ((INDEX .LE. 0) .OR.
	1	(INDEX .GT. 10)) GOTO 1000
	IF (TMPOUT) GOTO 20
	CALL SAVCTX (INDEX)
	INPTR = INPTR - 1
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	RETURN

20	CONTEX (1, INDEX) = NEGCNT
	CONTEX (9, INDEX) = 1
	CALL OUT2LN
	RETURN

C	ERROR REPORTING

1000	TYPE 1010
1010	FORMAT (' INVALID ARGUMENT TO MARK COMMAND')
	RETURN
	END

C	REVISION HISTORY:
C		22-03-77	CP	RENAME THIS ROUTINE TO PPOINT FROM
C					PORIG. IF POINTING IN A NEGATIVE
C					CONTEXT, SAVE THE CURRENT NEGATIVE COUNT
C					IF IT IS A NEW MAXIMUM, AND RESTORE
C					THE NEGATIVE COUNT AT THE TIME OF THE
C					SPECIFIED MARK. THEN OUTPUT THE LINE
C					TO THE TMP FILE.
C					HAVE THIS ROUTINE ALSO HANDLE REORIGINS.
C					THEY ARE THE SAME AS POINTS ONLY FEWER
C					CONTEXT VARIABLES ARE RESET.
C					IN THE ERROR CHECK FOR AN UNSAVED MARK,
C					CHECK THE FIFTH POSITION INSTEAD OF THE
C					FIRST, SINCE BLFOFS CAN BE NEGATIVE.
C
C		13-04-77	TC	SAVING OF THE MAXIMUM NEGATIVE
C					COUNT ELIMINATED: MAXIMUM OFFSET
C					WILL ALWAYS BE POSITIVE OR ZERO.
C					POINT OR ORIGIN TO A PLACE
C					OUTSIDE THE CURRENT NEGATIVE
C					BLOCK TERMINATES THE BLOCK.
C
C		19-04-77	TC	USE THE NEW CONTEX VARIABLE
C					DISCUSSED IN SRC$:MDL32CMN.CMN
C
C		26-04-77	TC	MAKE "O" TERMINATE NEGATIVE
C					FIELD BLOCK REGARDLESS.

	SUBROUTINE PPOINT

C	RESTORES THE CONTEXT OF THE STRUCTURE DECLARATION AT THE
C	TIME OF A PREVIOUS MARK COMMAND. IF NO ARGUMENT IS GIVEN TO
C	THE REORIGIN COMMAND, THE CONTEXT OF THE MAXIMUM STRUCTURE
C	CONTEXT IS RESTORED.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER INDEX

	CALL GETTOK
	IF (TOKTYP .NE. NUMBER) GOTO 20
	INDEX = INTVAL (TOKSTG)
	IF ((INDEX .LE. 0) .OR.
	1	(INDEX .GT. 10)) GOTO 1000
	IF (CONTEX (9, INDEX) .LT. 0) GOTO 1100
	IF (TMPOUT) GOTO 50

C	SEE IF THE CURRENT STRUCTURE CONTEXT IS THE GREATEST
C	(LARGEST) YET. IF SO, SAVE IT AS THE NEW MAXIMUM VALUES.

	IF (BLFOFS .GT. CONTEX (1, 11)) CALL SAVCTX (11)
	GOTO 30

C	NO ARGUMENT WAS GIVEN. JUST REORIGIN TO THE MAXIMUM CONTEXT.

20	INDEX = 11
	IF (TMPOUT) GOTO 50
30	IF (LINTYP .EQ. ORIGIN) GOTO 35
	CALL RESCTX (INDEX)
	GOTO 40

35	CALL RESETO (INDEX)
40	INPTR = INPTR - 1
	LINTYP = ORIGIN
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	RETURN

C	POINTER OR ORIGIN  IN NEGATIVE CONTEXT.

50	IF (LINTYP .EQ. ORIGIN) GOTO 55
	IF (CONTEX (9, INDEX) .LE. 0) GOTO 55
	NEGCNT = CONTEX (1, INDEX)
	CALL OUT2LN
	RETURN

C	POINTS OUTSIDE BLOCK OR IS AN "O" COMMAND

55	CALL OUT2LN
	CALL STANEG
	RETURN

C	ERROR REPORTING

1000	TYPE 1010
1010	FORMAT (' INVALID POSITION NAME')
	RETURN

1100	TYPE 1020
1020	FORMAT (' POSITION NAME NOT DEFINED')
	RETURN
	END

C	REVISION HISTORY
C		19-04-77	TC	USE NEW CONTEX VARIABLE DISCUSSED
C					IN SRC$:MDL32CMN.CMN

	SUBROUTINE SAVCTX (IND)

C	SAVES THE CONTEXT OF THE STRUCTURE DECLARATION. THE
C	VARIABLES SAVED ARE AS FOLLOWS:
C
C	BLFOFS	- THE TOTAL NUMBER OF BYTES ALLOCATED SO FAR.
C	BOFSET	- THE BASE OFFSET OF THE LAST GROUP OF SUBFIELDS.
C	FOFSET	- THE VALUE BLFOFS WILL BECOME WHEN THE TOTAL ALLOCATION
C		  IS PERFORMED FOR THE LAST FIELD DECLARATION.
C	SOFSET	- THE VALUE BLFOFS WILL BECOME WHEN THE ALLOCATION
C		  IS PERFORMED FOR THE LAST SUBFIELD DECLARATION.
C	LFDSIZ	- THE SIZE IN BYTES OF THE LAST FIELD DEFINED.
C	LSBSIZ	- THE TOTAL SIZE IN BYTES OF THE LAST SUBFIELD DEFINED.
C	LASLIN	- THE TYPE OF THE LAST DEFINITION LINE PROCESSED.
C	FLDLAS	- A BOOLEAN THAT TELLS WHETHER THE LAST DEFINITION
C		  PROCESSED WAS A FIELD OR A SUBFIELD, OR NEITHER.
C		  TRUE MEANS FIELD OR SUBFIELD. FALSE MEANS SOMETHING ELSE.
C
C	THE ARGUMENT IND IS THE INDEX INTO THE CONTEXT TABLE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER IND

	CONTEX (1, IND) = BLFOFS
	CONTEX (2, IND) = BOFSET
	CONTEX (3, IND) = FOFSET
	CONTEX (4, IND) = SOFSET
	CONTEX (5, IND) = LFDSIZ
	CONTEX (6, IND) = LSBSIZ
	CONTEX (7, IND) = LASLIN
	CONTEX (8, IND) = FLDLAS
	CONTEX (9, IND) = 0
	RETURN
	END

	SUBROUTINE RESCTX (IND)

C	RESTORES THE CONTEXT OF THE STRUCTURE DECLARATION. THE
C	ORDER AND DEFINITION OF THE VARIABLES ARE DESCRIBED IN
C	THE PROLOGUE FOR SAVCTX. THE ARGUMENT IND IS THE INDEX INTO THE
C	CONTEXT TABLE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER IND

	BLFOFS = CONTEX (1, IND)
	BOFSET = CONTEX (2, IND)
	FOFSET = CONTEX (3, IND)
	SOFSET = CONTEX (4, IND)
	LFDSIZ = CONTEX (5, IND)
	LSBSIZ = CONTEX (6, IND)
	LASLIN = CONTEX (7, IND)
	FLDLAS = CONTEX (8, IND)
	RETURN
	END

	SUBROUTINE RESETO (IND)

C	THIS IS A NEW ROUTINE IN VERSION 1.3.
C
C	IT RESETS THE CONTEXT OF A PREVIOUSLY MARKED POINT. IT ONLY
C	RESETS A FEW VARIABLES. ALL OTHER CONTEXT VARIABLES ARE
C	SET TO THEIR VALUES AT THE BEGINNING OF THE STRUCTURE
C	DEFINITION.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER IND

	BLFOFS = CONTEX (1, IND)
	BOFSET = 0
	FOFSET = BLFOFS
	SOFSET = 0
	LFDSIZ = 0
	LSBSIZ = 0
	FLDLAS = .FALSE.
	LASLIN = 0
	RETURN
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C	REVISION HISTORY:
C		29-06-77	TC	ROUTINE CHKMAK ELIMINATED (2.4)

	SUBROUTINE ETOBLS (INSTG, OUTSTG)

C	CONVERTS AN EXPRESSION TO STANDARD BLISS EXPRESSION
C	SYNTAX.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER INSTG(*),OUTSTG(*)
	INTEGER I, ICNT, J, K, L, M, N

	K = 2
	J = 2
2	IF (J .GT. (INSTG(1)+1)) GOTO 95
	DO 90 I = J, INSTG (1) + 1
	ICNT = I
	IF (INSTG (I) .NE. '<') GOTO 3
	OUTSTG (K) = '('
	GOTO 80

3	IF (INSTG (I) .NE. '>')  GOTO 6
	OUTSTG (K) = ')'
	GOTO 80

6	IF (INSTG (I) .NE. '@') GOTO 8
	OUTSTG (K) = '^'
	GOTO 80

8	IF (INSTG (I) .NE. '!') GOTO 10
	OUTSTG (K) = ' '
	K = K + 1
	OUTSTG (K) = 'O'
	K = K + 1
	OUTSTG (K) = 'R'
	K = K + 1
	OUTSTG (K) = ' '
	GOTO 80

10	IF (INSTG (I) .NE. '&') GOTO 15
	OUTSTG (K) = ' '
	K = K + 1
	OUTSTG (K) = 'A'
	K = K + 1
	OUTSTG (K) = 'N'
	K = K + 1
	OUTSTG (K) = 'D'
	K = K + 1
	OUTSTG (K) = ' '
	GOTO 80

15	IF ((INSTG (I) .NE. '^') .OR.
	1	(INSTG (I + 1) .NE. 'C')) GOTO 20
	OUTSTG (K) = ' '
	K = K + 1
	OUTSTG (K) = 'N'
	K = K + 1
	OUTSTG (K) = 'O'
	K = K + 1
	OUTSTG (K) = 'T'
	K = K + 1
	OUTSTG (K) = ' '
	GOTO 100

20	IF ((INSTG (I) .NE. '^') .OR.
	1	(INSTG (I + 1) .NE. 'B')) GOTO 35
	OUTSTG (K) = '%'
	K = K + 1
	OUTSTG (K) = 'B'
	K = K + 1
	OUTSTG (K) = ''''
	K = K + 1
	L = 0
	DO 25 M = I + 2, INSTG (1) + 1
	IF ((INSTG (M) .NE. '1') .AND.
	1	(INSTG (M) .NE. '0')) GOTO 30
	L = L + 1
	OUTSTG (K) = INSTG (M)
	K = K + 1
25	CONTINUE
30	OUTSTG (K) = ''''
	GOTO 110

35	IF ((INSTG (I) .NE. '^') .OR.
	1	(INSTG (I + 1) .NE. 'O')) GOTO 50
	OUTSTG (K) = '%'
	K = K + 1
	OUTSTG (K) = 'O'
	K = K + 1
	OUTSTG (K) = ''''
	K = K + 1
	L = 0
	DO 40 M = I + 2, INSTG (1) + 1
	IF ((INSTG (M) .LT. '0') .AND.
	1	(INSTG (M) .GT. '7')) GOTO 45
	L = L + 1
	OUTSTG (K) = INSTG (M)
	K = K + 1
40	CONTINUE
45	OUTSTG (K) = ''''
	GOTO 110

50	IF ((INSTG (I) .NE. '^') .OR.
	1	(INSTG (I + 1) .NE. 'X')) GOTO 65
	OUTSTG (K) = '%'
	K = K + 1
	OUTSTG (K) = 'X'
	K = K + 1
	OUTSTG (K) = ''''
	K = K + 1
	L = 0
	DO 55 M = I + 2, INSTG (1) + 1
	IF (((INSTG (M) .LT. '0') .OR.
	1	(INSTG (M) .GT. '9')) .AND.
	2	((INSTG (M) .LT. 'A') .OR.
	3	(INSTG (M) .GT. 'F'))) GOTO 60
	L = L + 1
	OUTSTG (K) = INSTG (M)
	K = K + 1
55	CONTINUE
60	OUTSTG (K) = ''''
	GOTO 110


65	IF ((INSTG (I) .NE. '^') .OR.
	1	(INSTG (I + 1) .NE. 'A')) GOTO 75
	DELIM = INSTG(I+2)
	OUTSTG (K) = ''''
	K = K + 1
	L = 1
	DO 66 M = (I + 3), (INSTG (1) + 1)
	IF (INSTG (M) .EQ. DELIM) GOTO 67
	OUTSTG (K) = INSTG (M)
	K = K + 1
	L = L + 1
66	CONTINUE
67	OUTSTG (K) = ''''
	L = L + 1
	GOTO 110


75	OUTSTG (K) = INSTG (I)

80	K = K + 1
C	IF (DEBUG) TYPE 500, K, I, OUTSTG (K - 1), INSTG (I + 1)
500	FORMAT (' OUTOFF ',I3,' INOFF ',I3,' CHAROUT ',A1,' NEXTCHAR ',A1)

90	CONTINUE
95	OUTSTG (1) = K - 2
	RETURN

100	J = ICNT + 2
	K = K + 1
	GOTO 2

110	J = ICNT + 2 + L
	K = K + 1
	GOTO 2
	END

C	REVISION HISTORY:
C		29-06-77	TC	ROUTINE ADDED (2.4)

	LOGICAL FUNCTION MTCHR(SRC,PNT,MCH)

C THIS SUBROUTINE CHECKS TO SEE IF THE STRING IN MCH MATCHES
C THE STRING IN SRC STARTING AT PNT.
C VARIABLES:
C	I	--	INDEXES SRC
C	J	--	INDEXES MCH
	INTEGER I,J,PNT
	INTEGER SRC(*),MCH(*)

C	INITILIZE
	I=PNT
	J=2

C	MAIN CODE
10	IF (SRC(I) .NE. MCH(J)) GOTO 20
	J=J+1
	IF (J.GT. (MCH(1)+1)) GOTO 30
	I=I+1
	IF (I.GT. (SRC(1)+1)) GOTO 20
	GOTO 10

C	FAILURE
20	MTCHR = .FALSE.
	RETURN

C	SUCCEED
30	MTCHR = .TRUE.
	RETURN
	END

C	REVISION HISTORY:
C		29-06-77	TC	ROUTINE ADDED (2.4)

	INTEGER FUNCTION ELIMPF(SRC,PNT,ARGSTR)

C	ELIMINATE THE PSEUDO-FUNCTION WHICH MAY START IN SRC AT PNT.
C	PLACE THE ARGUMENT IN ARGSTR.  RETURN VALUES ACCORDING TO THE
C	FOLLOWING SCHEME:
C		0	--	NO PSEUDO-FUNCTION
C		1	--	NO "(" FOUND
C		2	--	NO ")" FOUND
C		3	--	PSEUDO-FUNCTION WAS $BITPOSITION
C		4	--	PSEUDO-FUNCTION WAS $BYTEOFFSET
C		5	--	PSEUDO-FUNCTION WAS $FIELDWIDTH
C	IF THE VALUE RETURNED US 3, 4 OR 5; PNT IS UPDATED TO POINT
C	TO THE CHARACTER AFTER THE ")".  THIS MAY BE OFF THE END OF
C	THE STRING.
C	VARIABLES:
C		I	--	INDEXES SRC
C		J	--	INDEXES ARGSTR.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER I,J,PNT
	INTEGER SRC(*),ARGSTR(*)
	LOGICAL MTCHR

	I=PNT
	IF (MTCHR(SRC,I,DOLBIT)) GOTO 10
	IF (MTCHR(SRC,I,DOLBYT)) GOTO 20
	IF (MTCHR(SRC,I,DOLFLD)) GOTO 30

C	NOT A PSEUDO-FUNCTION
	ELIMPF=0
	RETURN

C	PSEUDO-FUNCTION IS $BITPOSITION
10	ELIMPF=3
	I=I+DOLBIT(1)
	GOTO 40

C	PSEUDO-FUNCTION IS $BYTEOFFSET
20	ELIMPF=4
	I=I+DOLBYT(1)
	GOTO 40

C	PSEUDO-FUNCTION IS $FIELDWIDTH
30	ELIMPF=5
	I=I+DOLFLD(1)

C	LOOK FOR "(", SKIPPING ANY SPACES
40	IF (I.GT.(SRC(1)+1))GOTO 50
	IF (SRC(I) .EQ. '(') GOTO 60
	IF ((SRC(I).NE.' ') .AND.
	1	(SRC(I).NE.'	')) GOTO 50
	I=I+1
	GOTO 40

C	COULDN'T FINE "("
50	ELIMPF=1
	RETURN

C	LOOK FOR ")". MOVE CHARACTERS PASSED OVER TO ARGSTR
60	J=2
	I=I+1
70	IF (I.GT.(SRC(1)+1)) GOTO 80
	IF (SRC(I) .EQ. ')') GOTO 90
	ARGSTR(J)=SRC(I)
	I=I+1
	J=J+1
	GOTO 70

C	COULDN'T FIND ")"
80	ELIMPF = 2
	RETURN

C	WE'RE DONE. CLEAN UP AND RETURN.
90	ARGSTR(1)=J-2
	PNT=I+1
	RETURN
	END

C	REVISION HISTORY:
C		29-06-77	TC	ROUTINE ADDED (2.4)
C
C		17-02-80		TIM HALVORSEN
C					ALLOW _V_ AS WELL AS $V_

	SUBROUTINE ETOMAR(SRC,DST)

C CONVERTS AN EXPRESSION TO STANDARD MARS SYNTAX.
C THE FOLLOWING VARIABLES ARE USED:
C	TMPSTG	--	HOLDS THE ARGUMENT TO A PSEUDO-FUNCTION
C	I	--	INDEXES THE SOURCE STRING
C	J	--	INDEXES THE DESTINATION STRING
C	K	--	INDEXES TMPSTG
C	CODE	--	RESULT FROM ELIMPF

	INTEGER I,J,K,CODE
	INTEGER SRC(*),DST(*),TMPSTG(81)
	INTEGER ELIMPF

C	INITILIZE
	I=2
	J=2

C	MAIN LOOP (THIS IS A FOR LOOP WITH AN INITIAL CHECK)
10	IF (I .GT. (SRC(1)+1)) GOTO 100
	IF (SRC(I) .NE. '$') GOTO 90

C	WE HAVE FOUND A DOLLAR SIGN.  IT MAY BE A PSEUDO-FUNCTION
	CODE = ELIMPF(SRC,I,TMPSTG)
C	CODE=0 -- NOT A PSEUDO-FUNCTION
	IF (CODE .EQ. 0) GOTO 90

C	CODE=1 -- ERROR: NO OPEN PARENTHESIS
	IF (CODE .EQ. 1) GOTO 70

C	CODE=2 -- ERROR: NO CLOSE PARENTHESIS
	IF (CODE .EQ. 2) GOTO 60

C	CODE=3 -- PSEUDO-FUNCTION WAS $BITPOSITION
	IF (CODE .EQ. 3) GOTO 40

C	CODE=4 -- PSEUDO-FUNCTION WAS $BYTEOFFSET
	IF (CODE .EQ. 4) GOTO 40

C	CODE MUST EQUAL 5 -- PSEUDO-FUNCTION WAS $FIELDWIDTH
C	WE MUST CHANGE "$V_" IN THE ARGUMENT TO "$S_"
	K=2
20	IF (K .GT. TMPSTG(1)-1) GOTO 80
	IF (TMPSTG(K) .NE. '$' .AND. TMPSTG(K) .NE. '_') GOTO 30
	IF (TMPSTG(K+1) .NE. 'V') GOTO 30
	IF (TMPSTG(K+2) .NE. '_') GOTO 30
	TMPSTG(K+1)='S'
	GOTO 40
30	K=K+1
	GOTO 20

C	COPY THE PSEUDO-FUNCTION ARGUMENT TO THE DESTINATION STRING
40	K=2
50	IF(K.GT.(TMPSTG(1)+1)) GOTO 10
	DST(J)=TMPSTG(K)
	J=J+1
	K=K+1
	GOTO 50

C	ERROR -- 
60	TYPE 1000
1000	FORMAT(' NO CLOSE PARENTHESIS FOR PSEUDO-FUNCTION')
	GOTO 90

C	ERROR --
70	TYPE 1010
1010	FORMAT(' NO OPEN PARENTHESIS FOR PSEUDO-FUNTION')
	GOTO 90

C	ERROR --
80	TYPE 1020
1020	FORMAT(' ARGUMENT TO $FIELDWIDTH IS NOT A VIELD')
	GOTO 40

C	JUST COPY THE CHARACTER FROM SOURCE TO DESTINATION
90	DST(J)=SRC(I)
	J=J+1
	I=I+1
	GOTO 10

C	END OF THE LOOP
100	DST(1)=J-2
	RETURN
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C	REVISION HISTORY:
C		22-03-77	CP	ADD LOGIC AT LABEL 30 TO SEND LINE TO
C					THE TMP FILE IF THIS IS A NEGATIVE
C					FIELD DEFINITION.
C		04-04-77	TC	ADD LOGIC TO KEEP TRACK OF MNGCNT
C					(MAXIMUM NEGATIVE COUNT)

	SUBROUTINE PFIELD

C	THIS ROUTINE IS CALLED WHEN A LINE HAS BEEN RECOGNIZED
C	AS A FIELD DEFINITION. THE IMPLICIT ARGUMENT INPTR IS THE OFFSET
C	TO THE NEXT CHARACTER TO BE READ IN THE INPUT LINE.

C	PFIELD COLLECTS THE ARGUMENTS OF THE FIELD DEFINITION,
C	AND THEN OUTPUTS APPROPRIATE STATEMENTS TO THE BLISS
C	AND MARS TRANSLATED FILES.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

C	INITIALIZE THE DEFAULT VALUES FOR UNIT DESCRIPTOR,
C	NUMBER OF BYTES PER UNIT, NUMBER OF UNITS, AND SIGN.

	CALL INIFLD

C	GET THE FIRST TOKEN. VALID TOKENS ARE
C	ALPHA (THE FIELDNAME) OR COMMA (MEANING THAT NO NAME
C	IS BEING DEFINED, SPACE IS SIMPLY BEING RESERVED).

	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
500	FORMAT (' ',90A1)
	IF (TOKTYP .NE. ALPHA) GOTO 10
	CALL MOVSTG (TOKSTG, FLDNAM)
	IF (DEBUG) TYPE 500, (FLDNAM (I), I = 2, FLDNAM (1) + 1)
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	NAME, IF ANY, HAS BEEN SAVED. NOW LOOK FOR A UNIT
C	DESCRIPTOR ARGUMENT. VALID CHARACTERS FOR THIS
C	ARGUMENT ARE L, B, W, Q, AND T.

10	IF (DEBUG) TYPE 420, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 25
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 15
	CALL GETUND
	IF (UNDOK .EQ. .FALSE.) GOTO 100
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	UNIT DESCRIPTOR, IF ANY, HAS BEEN SAVED. NOW LOOK FOR
C	THE SIZE ARGUMENT.

15	IF (DEBUG) TYPE 420, TOKTYP
420	FORMAT (' TOKTYP IS ',I3)
	IF (TOKTYP .NE. COMMA) GOTO 25
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. NUMBER) GOTO 20
	FSIZ = INTVAL (TOKSTG)
	IF (FSIZ .EQ. -1) GOTO 110
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	SIZE OF FIELD, IF ANY, HAS BEEN SAVED. NOW LOOK FOR
C	THE SIGN ARGUMENT.

20	IF (DEBUG) TYPE 420, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 25
C	IF (DEBUG) TYPE 430
430	FORMAT (' GETTING SIGN')
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 25
	IF (TOKSTG (1) .NE. 1) GOTO 120
	IF (TOKSTG (2) .NE. 'S') GOTO 120
	FSIGN = 1
	ASIGN (2) = '1'
	INPTR = INPTR - 1
	GOTO 30

C	THE OFFSET INTO THE INPUT BUFFER IS OFF BY ONE CHARACTER
C	BECAUSE SOME TRAILING OPTIONAL ARGUMENTS WERE OMITTED.  BACK
C	UP THE OFFSET BY ONE.

25	INPTR = LASTNB (INPTR - 2)

C	IF THIS IS A NEGATIVE FIELD DECLARATION, OUTPUT IT
C	TO THE TMP FILE.

30	IF (POSOFF) GOTO 40
	IF ((.NOT. TMPOUT) .AND. (FLDLAS)) CALL CHKALC
	IF (.NOT. TMPOUT) GOTO 35
	NEGCNT = NEGCNT + FSIZ * UNISIZ
	MNGCNT = MAX0(NEGCNT,MNGCNT)
	CALL OUT2LN
	RETURN

35	NEGCNT = FSIZ * UNISIZ
	MNGCNT = NEGCNT
	TMPOUT = .TRUE.
	CALL OUT2LN
	RETURN

40	IF (.NOT. TMPOUT) GOTO 45
	CALL OUT2LN
	CALL STANEG
	RETURN

C	FIELDS ARE ALL COLLECTED. NOW OUTPUT LINES TO
C	BLISS AND MARS.

45	SOFSET = 0
	FLDLAS = .TRUE.
	LFDSIZ = FSIZ * UNISIZ
	LSBSIZ = 0
	CALL SAVSBA
	INBUF (INPTR) = INBUF (1) - INPTR + 1
	CALL GETREM (INPTR)
	CALL OUTFLD
	RETURN

C	ERROR REPORTING

100	TYPE 1000
1000	FORMAT (' INVALID UNIT DESCRIPTOR IN FIELD DEFINITION')
	RETURN

110	TYPE 1100
1100	FORMAT (' INVALID SIZE IN FIELD DEFINITION')
	RETURN

120	TYPE 1200
1200	FORMAT (' INVALID SIGN ARGUMENT IN FIELD DEFINITION')
	END

	SUBROUTINE PSBFLD

C	THIS ROUTINE IS CALLED WHEN A LINE HAS BEEN RECOGNIZED
C	AS A SUBFIELD DEFINITION. THE IMPLICIT ARGUMENT
C	INPTR IS THE OFFSET TO THE NEXT CHARACTER IN THE INPUT LINE.

C	PSBFLD COLLECTS THE NAME OF THE SUBFIELD, THE OFFSET,
C	THE UNIT, THE SIZE, AND THE SIGN. THEN IT OUTPUTS
C	APPROPRIATE STATEMENTS TO THE BLISS AND MARS TRANSLATED FILES.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER LOCAL, COUNT, OSFSET

C	INITIALIZE THE OFFSET, UNIT TYPE, SIZE, SIGN, AND
C	NAME FIELDS

	LOCAL = -1
	CALL INIFLD

C	PICK UP THE NAME TOKEN

	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
500	FORMAT (' ',90A1)
	IF (TOKTYP .NE. ALPHA) GOTO 10
	CALL MOVSTG (TOKSTG, FLDNAM)
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	NAME, IF ANY, IS RETRIEVED. NOW CHECK FOR AN OFFSET ARGUMENT.

10	IF (DEBUG) TYPE 420, TOKTYP
420	FORMAT (' TOKTYP IS ',I3)
	IF (TOKTYP .NE. COMMA) GOTO 30
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. NUMBER) GOTO 15
	LOCAL = INTVAL (TOKSTG)
	IF (DEBUG) TYPE 310, LOCAL, SOFSET, LSBSIZ
310	FORMAT (' OFFSET ',I3,' SOFSET ',I3,' LSBSIZ ',I3)
	IF (LOCAL .EQ. -1) GOTO 100
	IF ((LOCAL + BOFSET) .LT. BLFOFS) GOTO 105

C	NOW LOOK FOR A UNIT DESCRIPTOR FIELD.

	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	OFFSET ARGUMENT, IF ANY, HAS BEEN COLLECTED. NOW LOOK FOR
C	A UNIT DESCRIPTOR ARGUMENT.

15	IF (DEBUG) TYPE 420, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 30
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 20
	CALL GETUND (TOKSTG)
	IF (UNDOK .EQ. .FALSE.) GOTO 110
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	UNIT DESCRIPTOR, IF ANY, HAS BEEN SAVED. NOW LOOK FOR
C	THE SIZE ARGUMENT.

20	IF (DEBUG) TYPE 420, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 30
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. NUMBER) GOTO 25
	FSIZ = INTVAL (TOKSTG)
	IF (FSIZ .EQ. -1) GOTO 120
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	SIZE OF SUBFIELD, IF ANY, HAS BEEN SAVED. NOW
C	LOOK FOR THE SIGN ARGUMENT.

25	IF (DEBUG) TYPE 420, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 30
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 30
	IF (TOKSTG (1) .NE. 1) GOTO 130
	IF (TOKSTG (2) .NE. 'S') GOTO 130
	FSIGN = 1
	ASIGN (2) = '1'
	INPTR = INPTR - 1
	GOTO 35

C	FIELDS ARE ALL COLLECTED. NOW OUTPUT LINES TO BLISS AND
C	MARS, AND UPDATE SUBFIELD OFFSET COUNTER. IF SOME
C	TRAILING FIELDS WERE OMITTED, THE INPUT LINE POINTER
C	IS ONE CHARACTER TOO FAR. BACK IT UP TO THE CORRECT
C	POSITION.

30	INPTR = LASTNB (INPTR - 2)

35	IF (DEBUG) TYPE 430, BLFOFS, LSBSIZ, FOFSET, SOFSET
430	FORMAT (' BLFOFS ',I3,' LSBSIZ ',I3,' FOFSET ',I3,' SOFSET ',I3)

C	SEE WHAT SORT OF ALLOCATION TO DO.

	IF (LOCAL .EQ. -1) GOTO 40
	IF (LOCAL .GT. SOFSET) GOTO 45
	IF (LOCAL .LT. SOFSET) GOTO 50

C	IN THIS CASE, THE OFFSET SPECIFIED IS EQUAL TO THE
C	CURRENT SUBFIELD OFFSET. JUST OUTPUT THE SIZE OF THE LAST SUBFIELD,
C	IF ANY.

	IF (DEBUG) TYPE 440, LSBSIZ
440	FORMAT (' OFFSET REMAINS SAME, OUTPUT LSBSIZ ',I3)
	IF (LSBSIZ .NE. 0) CALL OUTBLK (LSBSIZ)
	GOTO 60

C	HERE, NO OFFSET WAS SPECIFIED, JUST OUTPUT THE SIZE OF THE
C	LAST SUBFIELD.

40	IF (DEBUG) TYPE 450, LSBSIZ
450	FORMAT (' NO OFFSET SPECIFIED, OUTPUT LSBSIZ ',I3)
	IF (LSBSIZ .NE. 0) CALL OUTBLK (LSBSIZ)
	GOTO 60

C	HERE, THE OFFSET SPECIFIED WAS GREATER THAN THE CURRENT
C	SUBFIELD OFFSET. OUTPUT THE SIZE OF THE LAST FIELD, AND THEN
C	OUTPUT THE ADDITIONAL BYTES TO BRING IT UP TO THE SPECIFIED
C	OFFSET.

45	IF (DEBUG) TYPE 460, LOCAL, LSBSIZ
460	FORMAT (' OFFSET SPECIFIED IS ',I3,' OUTPUT LSBSIZ ',I3)
	IF (LSBSIZ .NE. 0) CALL OUTBLK (LSBSIZ)
	COUNT = LOCAL - SOFSET
	IF (DEBUG) TYPE 470, COUNT
470	FORMAT (' NOW ADDITIONAL SIZE OF ',I3)
	IF (COUNT .NE. 0) CALL OUTBLK (COUNT)
	SOFSET = LOCAL
	GOTO 60

C	HERE, THE OFFSET SPECIFIED WAS LESS THAN THE CURRENT
C	SUBFIELD OFFSET. REDUCE THE CURRENT OFFSET TO THAT SPECIFIED.
C	COMPUTE THE NOW REDUCED SIZE OF THE LAST SUBFIELD, AND ALLOCATE
C	THAT AMOUNT.

50	IF (DEBUG) TYPE 480, LOCAL, LSBSIZ
480	FORMAT (' REDUCED OFFSET IS ',I3,', LAST LSBSIZ IS ',I3)
	OSFSET = SOFSET - LSBSIZ
	SOFSET = LOCAL
	LSBSIZ = SOFSET - OSFSET
	IF (DEBUG) TYPE 490, LSBSIZ
490	FORMAT (' NEW LSBSIZ IS ',I3)
	IF (LSBSIZ .NE. 0) CALL OUTBLK (LSBSIZ)
	GOTO 60

C	NOW SET UP ALL THE FIELDS AND OUTPUT THE FIELD NAME.

60	IF ((SOFSET + (FSIZ * UNISIZ)) .GT. LFDSIZ) GOTO 125
	FLDLAS = .TRUE.
	LSBSIZ = FSIZ * UNISIZ
	CALL SAVSBA
	INBUF (INPTR) = INBUF (1) - INPTR + 1
	CALL GETREM (INPTR)
	CALL OUTFLD
	RETURN

C	ERROR REPORTING

100	TYPE 1000
1000	FORMAT (' INVALID OFFSET IN SUBFIELD DEFINITION')
	RETURN

105	TYPE 1010
1010	FORMAT (' SUBFIELD OFFSET OUT OF ORDER')
	RETURN

110	TYPE 1100
1100	FORMAT (' INVALID UNIT DESCRIPTOR IN SUBFIELD DEFINITION')
	RETURN

120	TYPE 1200
1200	FORMAT (' INVALID SIZE IN SUBFIELD DEFINITION')
	RETURN

125	TYPE 1210
1210	FORMAT (' SUBFIELD SIZE TOO LARGE')
	RETURN

130	TYPE 1300
1300	FORMAT (' INVALID SIGN ARGUMENT IN SUBFIELD DEFINITION')
	RETURN
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C	MDL MAINLINE
C
	INCLUDE 'SRC$:MDL32CMN.CMN'
C
C	INITIALISE
C
	INP = 2
	MAR = 1
	BLI = 3
	TMP = 4
	MAS = 8
C
	CALL INISTG
	CALL GETCMD
	END

	BLOCK DATA
C
C INITIALISE STATIC DATA FOR MDL
C
	INCLUDE 'SRC$:MDL32CMN.CMN'
	DATA BLANK,TAB,EOLCH/' ','	',0/
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C REVISION HISTORY:
C	22-03-77	CP	ADD TMP FILE OPEN AND CLOSE.
C
C  VARIABLES:
C
C	BLINAM--OUTPUT FILE SPECIFICATION FOR BLISS.
C	INPNAM--INPUT FILE SPECIFICATION
C	ISWTCH--VALUE OF SWITCHES SPECIFIED WITH INPUT FILE SPECIFICATION
C	MARNAM--OUTPUT FILE SPECIFICATION FOR MARS
C	OSWTCH--VALUE OF SWITCHES SPECIFIED WITH OUTPUT FILE SPECIFICATION
C	TMPNAM--TMP FILE SPECIFICATION.
C
C

	SUBROUTINE GETCMD
C
C	INCLUDE COMMON FILE
C
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
C
C	DATA DECLARATIONS
C
	CHARACTER*80 INPNAM,MARNAM,BLINAM
	CHARACTER*132 COMLINE
C
C	GET COMMAND LINE PARAMETERS.
C
	IERR=LIB$GET_FOREIGN(COMLINE,'MDL>',LLEN)
50	CONTINUE
	IF ((IERR.AND.1).EQ.0) CALL LIB$STOP(%VAL(IERR))
	EQSIGN=INDEX(COMLINE,'=')
	IF (EQSIGN.EQ.0) STOP 'No input'
	INPNAM=COMLINE(EQSIGN+1:LLEN)
	I=INDEX(INPNAM,']')
	IF (I.EQ.0) I=INDEX(INPNAM,'>')
	IF (INDEX(INPNAM(I+1:80),'.').NE.0) GOTO 60
	INPNAM(77:80)='.MDL'
C
C	SET UP OUTPUT FILE SPECIFICATIONS.
C
60	IF (EQSIGN.EQ.1) THEN
	  MARNAM=INPNAM
	  BLINAM=INPNAM
	  I=INDEX(INPNAM(I+1:80),'.')
	  MARNAM(I:I+3)='.MAR'
	  BLINAM(I:I+3)='.B32'
	 ELSE
	  ENDOUT=INDEX(COMLINE,',')
	  IF (ENDOUT.EQ.0) ENDOUT=EQSIGN
	  MARNAM=COMLINE(1:ENDOUT-1)
	  IF (ENDOUT.EQ.EQSIGN) THEN
	    BLINAM=MARNAM
	   ELSE
	    BLINAM=COMLINE(ENDOUT+1:EQSIGN-1)
	  ENDIF
	ENDIF
	I=INDEX(MARNAM,']')
	IF (I.EQ.0) I=INDEX(MARNAM,'>')
	IF (INDEX(MARNAM(I+1:80),'.').EQ.0) MARNAM(77:80)='.MAR'
	I=INDEX(BLINAM,']')
	IF (I.EQ.0) I=INDEX(BLINAM,'>')
	IF (INDEX(BLINAM(I+1:80),'.').EQ.0) BLINAM(77:80)='.B32'
C
C	CREATE A NAME FOR THE BLISS OUTPUT FILE THAT IS THE SAME AS
C	FOR THE MARS OUTPUT FILE EXCEPT THAT THE EXTENSION IS .B32.
C
C	OPEN A TEMP FILE TO PUT THE FIRST PASS OF THE MARS OUTPUT IN.
C
C	OPEN A TEMP FILE TO ALLOW HANDLING OF NEGATIVE FIELDS.
C
C	OPEN AND PROCESS THE FILES.
C
	OPEN( UNIT=INP,TYPE='OLD',NAME=INPNAM,
	1	ACCESS='SEQUENTIAL',READONLY,ERR=500)
	OPEN( UNIT=MAR,TYPE='SCRATCH',NAME='SYS$LOGIN:MAROUT.TMP',
	1	ACCESS='SEQUENTIAL',ERR=530)
	OPEN( UNIT=MAS,TYPE='NEW',NAME=MARNAM,CARRIAGECONTROL='LIST',
	1	ACCESS='SEQUENTIAL',ERR=510)
	OPEN( UNIT=BLI,TYPE='NEW',NAME=BLINAM,!CARRIAGECONTROL='NONE',
	1	ACCESS='SEQUENTIAL',ERR=520)
	OPEN( UNIT=TMP,TYPE='SCRATCH',NAME='SYS$LOGIN:NEGFLD.TMP',
	1	FORM='UNFORMATTED',ACCESS='SEQUENTIAL',ERR=530)
	ENDFIL = .FALSE.
100	CALL STPROC
	IF (.NOT. ENDFIL) GOTO 100
	CLOSE (UNIT = BLI)
	CLOSE (UNIT = INP)
	CLOSE (UNIT = TMP, DISPOSE='DELETE')
	REWIND (UNIT = MAR)
	CALL REAREND
	CLOSE (UNIT = MAR, DISPOSE='DELETE')
	CLOSE (UNIT = MAS)
	CALL EXIT
C
C	ERROR OPENING INPUT FILE
C
500	TYPE 1010
1010	FORMAT (' %MDL-F-Error opening input file')
	RETURN

510	TYPE 1020
1020	FORMAT (' %MDL-F-Error opening mars output file')
	RETURN

520	TYPE 1030
1030	FORMAT (' %MDL-F-Error opening bliss output file')
	RETURN

530	TYPE 1040
1040	FORMAT (' %MDL-F-Error opening temp file')
	RETURN

	END

	SUBROUTINE LITSTG(CS,LS,NC)
C
C	CONVERT LITERAL STRING TO COUNTED STRING
C
	IMPLICIT INTEGER(A-Z)
	INTEGER LS(*),CS(*),A(30)
C
	N = NC/2+1
	ENCODE(60,100,A) (LS(I),I=1,N)
100	FORMAT(20A2)
	DECODE(60,200,A) (CS(I),I=2,NC+1)
200	FORMAT(150A1)
	CS(1) = NC
	RETURN
	END

	SUBROUTINE NUMSTG(CS,X)
C
C	CONVERT INTEGER TO COUNTED STRING
C
	IMPLICIT INTEGER(A-Z)
	INTEGER CS(*),A(10),B(10)
	ENCODE(20,100,A) X
100	FORMAT(I10)
	DECODE(10,200,A) B
200	FORMAT(10A1)
	DO 10 I = 1,10
10	IF(B(I).NE.' ')GOTO 20
20	CS(1)=11-I
	DO 30 J=I,10
30	CS(J-I+2) = B(J)
	RETURN
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  Copyright (c) 1980                                                      *
C*  by DIGITAL Equipment Corporation, Maynard, Mass.			    *
C* 									    *
C*  This software is furnished under a license and may be used and  copied  *
C*  only  in  accordance  with  the  terms  of  such  license and with the  *
C*  inclusion of the above copyright notice.  This software or  any  other  *
C*  copies  thereof may not be provided or otherwise made available to any  *
C*  other person.  No title to and ownership of  the  software  is  hereby  *
C*  transferred.							    *
C* 									    *
C*  The information in this software is subject to change  without  notice  *
C*  and  should  not  be  construed  as  a commitment by DIGITAL Equipment  *
C*  Corporation.							    *
C* 									    *
C*  DIGITAL assumes no responsibility for the use or  reliability  of  its  *
C*  software on equipment which is not supplied by DIGITAL.		    *
C*									    *
C****************************************************************************
C
C REVISION HISTORY:
C
C	TIM HALVORSEN	31-MAR-1980	ALLOW ANY LETTER AS UNIT NAME AND
C					ASSIGN UNIT SIZE OF 1 FOR UNKNOWNS
C


C		23-03-77	CP	INITIALIZE THE STRING SUFNAM TO
C					THE SAME STRING OF CHARACTERS AS
C					THE STRING SUFDEF.
	SUBROUTINE GETSTC


C	ONCE A LINE IS IDENTIFIED AS A STRUCTURE DECLARATION,
C	THIS SUBROUTINE, GETSTC, IS CALLED TO COLLECT THE NAME
C	OF THE STRUCTURE (HEREAFTER REFERRED TO AS THE PREFIX)
C	AND THE SUFFIX (OPTIONAL).

C	THE INPUT ARGUMENT IS THE SUBSCRIPT OFFSET TO THE NEXT
C	CHARACTER TO BE READ IN THE INPUT LINE.

C	IF AN ERROR IS DETECTED, THE LOGICAL VARIABLE STROK IS
C	SET TO FALSE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

C	FIRST INITIALIZE THE SUFFIX NAME TO THE DEFAULT VALUE.
C	ALSO INITIALIZE THE PREFIX NAME TO A LENGTH OF ZERO.

	DO 10 I = 1,4
	SUFNAM (I) = SUFDEF (I)
10	CONTINUE
	PRENAM (1) = 0

C	NOW LOOK FOR THE STRUCTURE PREFIX NAME.

	IF (DEBUG) TYPE 500
500	FORMAT (' INTO GETSTC')
	CALL GETTOK
	IF (TOKTYP .NE. ALPHA) GOTO 100
	CALL MOVSTG (TOKSTG, PRENAM)
C	IF (DEBUG) TYPE 510, (PRENAM (I), I = 2, PRENAM (1) + 1)
510	FORMAT (' PREFIX IS ',15A1)
	CALL GETTOK
	IF (TOKTYP .NE. COMMA) GOTO 15
	CALL GETTOK
	IF (TOKTYP .NE. ALPHA) GOTO 100
	CALL MOVSTG (TOKSTG, SUFNAM)
C	IF (DEBUG) TYPE 520, (SUFNAM (I), I = 2, SUFNAM (1) + 1)
520	FORMAT (' SUFFIX IS ',15A1)

15	INPTR = LASTNB (INPTR - 2)
20	CALL OUTSTR
	CALL INISTR
	STROK = .TRUE.
	RETURN

100	TYPE 1000
1000	FORMAT (' INVALID STRUCTURE DECLARATION')
	STROK = .FALSE.
	END

C	REVISION HISTORY:
C		22-03-77	CP	CHANGE ORIGIN TO POINTD, PORIG
C					TO PPOINT. ADD LEGAL DEFINITION
C					OF 'O', ORIGIN, SETS LINE TYPE TO
C					ORIGIN AND CALLS PPOINT.
C					ADD LOGIC TO HANDLE NEGATIVE OFFSETS.
C					BASICALLY, OF SEE A NEGATIVE FIELD,
C					OUTPUT THAT LINE AND ALL SUBSEQUENT
C					LINES UNTIL A POSITIVE FIELD IS SEEN TO
C					A TMP FILE. WHEN A POSITIVE FIELD IS
C					SEEN, PROCESS THE TMP FILE AS THOUGH
C					IT WERE THE SOURCE FILE, PRECEDING ITS
C					OUTPUT WITH A NEGATIVE BLKB DECLARATION.
C					THEN RESUME PROCESSING OF THE SOURCE FILE.
C
C
C		04-04-77	TC	CORRECT BUG IN RETURNING TO NORMAL
C					PROCESSING (CORRECTION DUE TO CP)
C					CHANGE START OF NEGATIVE OFFSET FIELDS
C					FROM NEGCNT TO MNGCNT (MAXIMUM NEGATIVE
C					COUNT).
C
C		17-02-80		TIM HALVORSEN
C					ADD 'STRUCT' KEYWORD TO SIGNIFY THE
C					BEGINNING OF A USER STRUCTURE DEFN.
C					THE ONLY DIFFERENCE IS THAT AN '_' IS
C					USED RATHER THAN '$' AFTER THE PREFIX.

	SUBROUTINE STPROC

C	INPUTS LINES UNTIL A $STRUCT DECLARATION IS FOUND.
C	THEN PROCEEDS TO PROCESS A STRUCTURE THROUGH THE
C	END STATEMENT OF THE DECLARATION.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
	INTEGER STRUSR(7),STRTYP

	DATA STRSTG(1)/7/,STRSTG(2)/'$'/,STRSTG(3)/'S'/,
	1	STRSTG(4)/'T'/,STRSTG(5)/'R'/,STRSTG(6)/'U'/,
	2	STRSTG(7)/'C'/,STRSTG(8)/'T'/
	DATA STRUSR(1)/6/,STRUSR(2)/'S'/,STRUSR(3)/'T'/,
	1	STRUSR(4)/'R'/,STRUSR(5)/'U'/,STRUSR(6)/'C'/,
	2	STRUSR(7)/'T'/

C	INPUT LINES UNTIL A STRUCT OR $STRUCT IS FOUND. THE
C	FIRST TOKEN IN THE LINE SHOULD BE TYPE ALPHA.

	IF (DEBUG) TYPE 1010
1010	FORMAT (' IN STPROC')

C	ASSUME SYSTEM TYPE STRUCTURE (USING '$')

	STRTYP = '$'

10	CALL GETLIN
	IF (.NOT. ENDFIL) GOTO 12
	IF (.NOT. TMPIN) RETURN
	REWIND TMP
	TMPIN = .FALSE.
	ENDFIL = .FALSE.
	GOTO 10

12	CALL GETTOK
	IF (DEBUG) TYPE 1000, TOKTYP
1000	FORMAT (' TOKTYP IS ',I2)
	IF (TOKTYP .NE. ALPHA) GOTO 15
	IF (DEBUG) TYPE 1020, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
1020	FORMAT (' TOKSTG IS ',15A1)
	CALL CMPSTG (TOKSTG, STRSTG)
	IF (STGEQL) GOTO 20
	CALL CMPSTG (TOKSTG, STRUSR)
	IF (STGEQL) GOTO 21

C	THIS LINE DOES NOT DECLARE A STRUCTURE. JUST OUTPUT IT
C	TO BOTH BLISS AND MARS AS IS.

15	CALL OUT2LN
	GOTO 10

C	USER STRUCTURE DECLARATION RECOGNIZED.  REMEMBER TO CHANGE
C	THE TAGNAM SO THAT UNDERSCORE IS USED RATHER THAN $.

21	STRTYP = '_'

C	STRUCTURE DECLARATION RECOGNIZED. COLLECT THE PREFIX AND
C	SUFFIX NAMES AND OUTPUT THE STRUCTURE DEFINITION LINES
C	(TAGNAM(2) IS SET TO INDICATE THE PROPER FORM OF MACRO NAME).

20	LINTYP = 0
	BLKOUT = .FALSE.
	TAGNAM (2) = STRTYP
	CALL GETSTC
	IF (STROK) GOTO 25
	RETURN

C	NOW INPUT A LINE AND SEE WHAT TYPE OF DEFINITION IT IS.
C	THE STRUCTURE VARIABLES HAVE BEEN INITIALIZED BY GETSTC.
C	(RESET TAGNAM(2) BECAUSE STRUCT INIT. SETS IT TO '$').

25	TAGNAM (2) = STRTYP
	POSOFF = .TRUE.
	CALL GETLIN
	IF (.NOT. ENDFIL) GOTO 30
	IF (.NOT. TMPIN) RETURN
	REWIND TMP
	TMPIN = .FALSE.
	ENDFIL = .FALSE.
	GOTO 25

30	CALL GETTOK
	IF (TOKTYP .EQ. MINUS) GOTO 35
	IF (TOKTYP .NE. PLUS) GOTO 45
	GOTO 40

35	POSOFF = .FALSE.
	INBUF (INPTR - 1) = '+'
	IF (.NOT. TMPIN) GOTO 40
	TYPE 2000
2000	FORMAT (' NEGATIVE DEFINITION IN TMP FILE')
	RETURN

40	CALL GETTOK
45	IF ((TOKTYP .EQ. ALPHA) .AND.
	1	(TOKSTG (1) .EQ. 1)) GOTO 55

50	CALL OUT2LN
	GOTO 25

55	IF (TOKSTG (2) .NE. 'F') GOTO 65
	IF (.NOT. POSOFF) GOTO 60
	IF (FLDLAS) CALL CHKALC

60	LINTYP = FIELD
	CALL PFIELD
	GOTO 25

65	IF (POSOFF) GOTO 70
	TYPE 2010
2010	FORMAT (' INVALID NEGATIVE DEFINITION')
	GOTO 50

70	IF (TOKSTG (2) .EQ. 'E') GOTO 155
	IF (TOKSTG (2) .EQ. 'M') GOTO 160
	IF (TOKSTG (2) .EQ. 'P') GOTO 165
	IF (TOKSTG (2) .EQ. 'O') GOTO 170
	IF (TOKSTG (2) .EQ. 'V') GOTO 140
	IF ((TOKSTG (2) .EQ. 'C') .OR.
	1	(TOKSTG (2) .EQ. 'K')) GOTO 145
	IF (TMPOUT) GOTO 50
	IF (TOKSTG (2) .EQ. 'S') GOTO 135
	IF (TOKSTG (2) .EQ. 'L') GOTO 150
	GOTO 50

C	PROCESS A SUBFIELD DECLARATION

135	LINTYP = SBFLD
	CALL PSBFLD
	GOTO 25

C	PROCESS A BITFIELD DECLARATION

140	LINTYP = VIELD
	CALL PVIELD
	GOTO 25

C	PROCESS A CONSTANT DECLARATION

145		LINTYP = CONST
	CALL PCONST
	GOTO 25

C	PROCESS A LABEL DECLARATION

150	IF (FLDLAS) CALL CHKALC
	LINTYP = LABELN
	CALL PLABEL
	GOTO 25

C	PROCESS AN END DECLARATION

155	IF (TMPOUT) GOTO 157
	IF (FLDLAS) CALL CHKALC
	CALL OUTSTE 
	RETURN

157	CALL OUT2LN
	CALL STANEG
	GOTO 25

C	THIS IS A POSITION MARKING

160	LINTYP = MARKPT
	CALL PMARK
	GOTO 25

C	THIS IS A POINT COMMAND

165	IF (FLDLAS) CALL CHKALC
	LINTYP = POINTD
	CALL PPOINT
	GOTO 25

C	THIS IS A REORIGINING COMMAND

170	IF (FLDLAS) CALL CHKALC
	LINTYP = ORIGIN
	CALL PPOINT
	GOTO 25

	END

C	REVISION HISTORY
C		11-04-77	TC	ELIMINATED EXTRANEOUS STATEMENT
C					NUMBER.
C

	SUBROUTINE STANEG

C	THIS IS A NEW ROUTINE, VERSION 1.3
C
C	THIS CLOSES THE TMP FILE FOR OUTPUT. REWINDS IT.
C	SETS FLAGS SO THAT INPUT NOW COMES FROM THE TMP
C	FILE. SETS ALL CONTEXT VARIABLES CORRECTLY.
C	OUTPUTS NEGATIVE BLOCK ALLOCATION IF NECESSARY.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	END FILE TMP
	REWIND TMP
	TMPIN = .TRUE.
	BLFOFS = BLFOFS - MNGCNT
	BOFSET = BLFOFS
	FOFSET = BLFOFS
	OUNSIZ = 1
	OUNTYP (2) = 'B'
	IF (MNGCNT .GT. 0) CALL OUTBLK (MNGCNT)
	FLDLAS = .FALSE.
	TMPOUT = .FALSE.
	RETURN
	END

	SUBROUTINE PLABEL

C	THIS ROUTINE IS CALLED WHEN A LINE HAS BEEN RECOGNIZED
C	AS A LABEL DEFINITION. THE IMPLIC ARGUMENT INPTR IS THE OFFSET
C	TO THE NEXT CHARACTER TO BE READ IN THE INPUT LINE.

C	PLABEL COLLECTS THE NAME OF THE LABEL BEING DEFINED AND
C	THEN OUTPUTS APPROPRIATE STATEMENTS TO THE BLISS AND MARS
C	TRANSLATED FILES.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	CALL GETTOK
	IF (TOKTYP .NE. ALPHA) GOTO 100
	CALL MOVSTG (TOKSTG, FLDNAM)
	TAGNAM (3) = 'C'
	INPTR = INPTR - 1
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	RETURN

C	ERROR REPORTING

100	TYPE 1000
1000	FORMAT (' INVALID LABEL DEFINITION')
	END


	SUBROUTINE GETUND

C	ANALYZES AN ALPHA STRING THAT CLAIMS TO BE A UNIT
C	DESCRIPTOR. IF IT IS VALID, STORES THE LETTER
C	IN UNITYP AND THE APPROPRIATE SIZE VALUE IN UNISIZ.
C	ALSO COMPOSES A TAG NAME STRING FROM A DOLLAR SIGN FOLLOWED
C	BY THE UNIT DESCRIPTOR LETTER, FOLLOWED BY AN UNDERSCORE.

C	THE IMPLICIT ARGUMENT IS THE COUNTED STRING, TOKSTG, THAT IS
C	THE UNIT DESCRIPTOR LETTER. A LOGICAL VARIABLE IS
C	SET TO TRUE OR FALSE ACCORDING TO THE VALIDITY OF THE
C	ARGUMENT.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

C	IF (DEBUG) TYPE 500
500	FORMAT (' IN UNIT DESCRIPTOR ANALYZER')
	IF (TOKSTG (1) .NE. 1) GOTO 100
	UNITYP (2) = TOKSTG (2)
	TAGNAM (3) = TOKSTG (2)

	IF (TOKSTG (2) .EQ. 'W') GOTO 15
	IF ((TOKSTG (2) .EQ. 'L')  .OR.	(TOKSTG (2) .EQ. 'A')) GOTO 20
	IF (TOKSTG (2) .EQ. 'Q') GOTO 25

	UNISIZ = 1
	UNITYP (2) = 'B'
	BLBITS = 8
	GOTO 30

15	UNISIZ = 2
	BLBITS = 16
	GOTO 30

20	UNISIZ = 4
	UNITYP (2) = 'L'
	BLBITS = 32
	GOTO 30

25	UNISIZ = 8
	BLBITS = 64

30	UNDOK = .TRUE.
	RETURN

100	UNDOK = .FALSE.
	RETURN
	END

C	REVISION HISTORY:
C		23-03-77	CP	IF SAVING INPUT IN TMP FILE, SAVE
C					EACH LINE OF A BITFIELD DECLARATION,
C					AND RETURN AFTER THE CLOSING RIGHT
C					ANGLE BRACKET.
C
C		22-04-77	TC	CALL BDOUTL AT START AND
C					END TO OUTPUT COMMENTS INTO
C					THE BLISS FILE.

	SUBROUTINE PVIELD

C	THIS ROUTINE IS CALLED WHEN ALINE HAS BEEN RECOGNIZED
C	AS A BITFIELD DEFINITION. THE IMPLICIT ARGUMENT
C	INPTR IS THE OFFSET TO THE NEXT CHARACTER IN THE INPUT LINE.

C	PVIELD COLLECTS THE MASK FLAG FOR THE SET OF BITFIELDS TO
C	BE DEFINED. THEN IT COLLECTS A BITFIELD DEFINITION AT A TIME.
C	EACH BITFIELD DEFINITION CAN HAVE A NAME, SIZE, SIGN, AND
C	INDIVIDUAL MASK. EACH BITFIELD IS PROCESSED AND OUTPUT.

C	WHEN A SINGLE LEADING RIGHT ANGLE BRACKET IS RECOGNIZED,
C	PROCESSING OF THE VIELD IS COMPLETE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

C	INITIALIZE MASK AND SIGN ARGUMENTS

	VMASK = .FALSE.
	AMASK (1) = 0
	ASIGN (1) = 1

	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
500	FORMAT (' ',90A1)
	IF (TOKTYP .NE. LANGLE) GOTO 100
	IF (TMPOUT) GOTO 50
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 10
	IF (TOKSTG (1) .NE. 1) GOTO 110
	IF (TOKSTG (2) .NE. 'M') GOTO 110
	VMASK = .TRUE.
	AMASK (1) = 1
	INPTR = INPTR - 1
	GOTO 12

C	THE POINTER INTO THE INPUT LINE IS TOO FAR ALONG, BACK IT
C	UP ONE POSITION.

10	INPTR = LASTNB (INPTR - 2)

C	NOW OUTPUT THE LINE THAT INITIATES A BITFIELD DEFINITION LIST.

12	VOFSET = 0
	TAGNAM (3) = 'V'
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)

C	INITIALIZE VARIABLES, AND INPUT A LINE.

15	VSIZ = 0
	FSIGN = 0
	SMASK = .FALSE.
	IF (.NOT. VMASK) AMASK (1) = 0
	ASIGN (2) = '0'
	DO 20 I = 1, 15
	FLDNAM (I) = 0
20	CONTINUE

21	CALL GETLIN
	IF (.NOT. ENDFIL) GOTO 22
	RETURN

C	CHECK THE FIRST TOKEN. IF IT IS A RIGHT ANGLE,
C	THIS IS THE LAST STATEMENT IN THE BITFIELD DEFINITIONS.

22	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (DEBUG) TYPE 510, TOKTYP
510	FORMAT (' TOKTYP IS ',I3)
	IF (TOKTYP .EQ. RANGLE) GOTO 90
	IF (TMPOUT) GOTO 50
	LINTYP = BITFNM

C	SEE IF THIS HAS A BITFIELD NAME OR IS END OF LINE

	IF (TOKTYP .EQ. ALPHA) GOTO 24
	IF ((TOKTYP .NE. SEMI) .AND.
	1	(TOKTYP .NE. EOL)) GOTO 25

C	THIS LINE IS BLANK OR ONLY COMMENTS

	CALL OUTBCL
	GOTO 21

C	THIS IS A BITFIELD NAME DEFINITION

24	CALL MOVSTG (TOKSTG, FLDNAM)
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	NOW LOOK FOR THE SIZE FIELD.

25	IF (DEBUG) TYPE 510, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 40
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. NUMBER) GOTO 30
	VSIZ = INTVAL (TOKSTG)
	IF (VSIZ .EQ. - 1) GOTO 120
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	NOW CHECK FOR A SIGN FIELD.

30	IF (DEBUG) TYPE 510, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 40
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 35
	IF (TOKSTG (1) .NE. 1) GOTO 130
	IF (TOKSTG (2) .NE. 'S') GOTO 130
	FSIGN = 1
	ASIGN (2) = '1'
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)

C	FINALLY, LOOK FOR A MASK ARGUMENT.

35	IF (DEBUG) TYPE 510, TOKTYP
	IF (TOKTYP .NE. COMMA) GOTO 40
	CALL GETTOK
	IF (DEBUG) TYPE 500, (TOKSTG (I), I = 2, TOKSTG (1) + 1)
	IF (TOKTYP .NE. ALPHA) GOTO 40
	IF (TOKSTG (1) .NE. 1) GOTO 110
	IF (TOKSTG (2) .NE. 'M') GOTO 110
	SMASK = .TRUE.
	AMASK (1) = 1
	INPTR = INPTR - 1
	GOTO 45

C	THE OFFSET INTO THE INPUT LINE IS ONE CHARACTER OFF
C	BECAUSE SOME TRAILING OPTIONAL ARGUMENTS WERE OMITTED. BACK UP
C	THE OFFSET COUNT BY ONE.

40	INPTR = LASTNB (INPTR - 2)

C	ARGUMENTS ARE ALL COLLECTED. OUTPUT THE LINE.

45	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	IF (VSIZ .EQ. 0) VOFSET = VOFSET + 1
	IF (VSIZ .GT. 0) VOFSET = VOFSET + VSIZ
	GOTO 15

C	IF OUTPUTTING TO TMP FILE, JUST DO IT, THEN GO FOR NEXT LINE.

50	CALL OUT2LN
	GOTO 21

C	OUTPUT THE FINAL CLOSING OF THE BITFIELD DEFINITIONS.

90	IF (TMPOUT) GOTO 95
	LINTYP = VIELDE
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	RETURN

C	OUTPUT THE FINAL CLOSING LINE TO TMP FILE AND RETURN.

95	CALL OUT2LN
	RETURN

C	ERROR REPORTING

100	TYPE 1000
1000	FORMAT (' INVALID BITFIELD DEFINITION')
	RETURN

110	TYPE 1100
1100	FORMAT (' INVALID MASK SPECIFICATION')
	RETURN

120	TYPE 1200
1200	FORMAT (' INVALID SIZE ARGUMENT IN BITFIELD DEFINITION')
	RETURN

130	TYPE 1300
1300	FORMAT (' INVALID SIGN ARGUMENT IN BITFIELD DEFINITION')
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C	REVISION HISTORY:
C		08-03-82		JIM TEAGUE # JWT0027
C					ADD SIZE SYMBOLS FOR FIELDS GREATER
C					THAN 4 BYTES LONG.  
C
C		**** BEWARE ***		THESE CAN POSSIBLY CAUSE CONFLICTS 
C					WITH BIT FIELD SIZES. 
C
C
C		19-02-80		TIM HALVORSEN
C					IF USER STRUCTURE, USE _VIELD RATHER
C					THAN $VIELD.
	SUBROUTINE MDOUTL (PTR)

C	OUTPUTS A LINE TO THE TRANSLATED MARS FILE.
C	THE ARGUMENT PTR POINTS TO THE LOGICAL END
C	OF LINE IN THE INPUT FILE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER PTR

	IF (DEBUG) TYPE 290
290	FORMAT (' IN MARS OUTPUT')
	IF (LINTYP .EQ. FIELD) GOTO 10
	IF (LINTYP .EQ. SBFLD) GOTO 20
	IF (LINTYP .EQ. VIELD) GOTO 30
	IF (LINTYP .EQ. VIELDE) GOTO 35
	IF (LINTYP .EQ. CONST) GOTO 40
	IF (LINTYP .EQ. CONSTE) GOTO 45
	IF (LINTYP .EQ. BITFNM) GOTO 50
	IF (LINTYP .EQ. CONSTN) GOTO 60
	IF (LINTYP .EQ. SCONST) GOTO 70
	IF (LINTYP .EQ. MARKPT) GOTO 80
	IF (LINTYP .EQ. ORIGIN) GOTO 90
	IF (LINTYP .NE. LABELN) GOTO 100

C	THIS IS A LABEL DEFINITION TO BE OUTPUT. THE FORMAT IS
C	'$DEF (TAB) PRENAM\TAGNAM\FLDNAM
C	 $DEF (TAB) PRENAM\KTAGNAM\FLDNAM' FOLLOWED BY THE REST OF THE
C	INPUT LINE, WHERE KTAGNAM IS THE TAGNAM WITH THE SECOND
C	CHARACTER CHANGED TO A 'K'.

	IF (DEBUG) TYPE 490
490	FORMAT (' LABEL OUTPUT')
	CALL PUTMAR (DOLDEF)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (TAGNAM)
	CALL PUTMAR (FLDNAM)
	CALL OUTMAR
	TAGNAM(3) = 'K'
	CALL PUTMAR (DOLDEF)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (TAGNAM)
	CALL PUTMAR (FLDNAM)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
300	FORMAT (' ',90A1)
	CALL OUTMAR
	RETURN

C	THIS IS A FIELD DEFINITION TO BE OUTPUT. THE FORMAT IS
C	'$DEF (TAB) PRENAM\TAGNAM\FLDNAM (TAB) .BLK\UNITYP'
C	FOLLOWED BY THE REST OF THE LINE.

10	IF (DEBUG) TYPE 500
500	FORMAT (' FIELD OUTPUT')
	CALL NUMSTG (BYTSIZ, OFSIZ)
	IF (OSBNAM (1) .EQ. 0) GOTO 11
	CALL PUTMAR (DOLDEF)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (OTGNAM)
	CALL PUTMAR (OSBNAM)
	GOTO 12

C	THIS IS JUST ALLOCATION OF SPACE, WITH NO ACCOMPANYING
C	FIELD NAME.

11	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)
12	IF (.NOT. BLKOUT) GOTO 13
	CALL PUTMAR (DOTBLK)
	CALL PUTMAR (OUNTYP)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (BYTSIZ)
	GOTO 15

C	THIS IS FOR NO BLOCK ALLOCATION

13	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)

15	CALL PUTMAR (SPCSTG)
	CALL PUTMAR (RSTLIN)
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
C===
C
C  JIM TEAGUE    3/8/82    ADD SIZE CONSTANTS TO MACRO OUTPUT
C
C  begin first code insertion
C
C===
	NBYTES = OFSIZ * OUNSIZ
	IF(NBYTES .LT. 5)GOTO 16
	IF(OSBNAM(1) .EQ. 0) GOTO 16
	CALL NUMSTG (BYTSIZ, NBYTES)
	CALL PUTMAR (EQUTAB)
	CALL PUTMAR (PRENAM)
	ISAVE = OTGNAM(3)
	OTGNAM(3) = 'S'
	CALL PUTMAR (OTGNAM)
	CALL PUTMAR (OSBNAM)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (BYTSIZ)
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	OTGNAM(3) = ISAVE
16	CONTINUE
C===
C
C  JIM TEAGUE    3/8/82    ADD SIZE CONSTANTS TO MACRO OUTPUT
C
C  end first code insertion
C
C===
	RETURN

C	THIS IS A SUBFIELD DEFINITION TO BE OUTPUT. THE FORMAT IS
C	'$DEF (TAB) PRENAM\TAGNAM\FLDNAM (TAB) .BLK\UNITYP'
C	FOLLOWED BY THE REST OF THE LINE.

20	IF (DEBUG) TYPE 510
510	FORMAT (' SUBFIELD OUTPUT')
	IF (OSBNAM (1) .EQ. 0) RETURN
	CALL PUTMAR (DOLDEF)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (OTGNAM)
	CALL PUTMAR (OSBNAM)
	IF (.NOT. BLKOUT) GOTO 23
	CALL PUTMAR (DOTBLK)
	CALL PUTMAR (OUNTYP)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (BYTSIZ)
	GOTO 25
23	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)
25	CALL PUTMAR (SPCSTG)
	CALL PUTMAR (RSTLIN)
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
C===
C
C  JIM TEAGUE    3/8/82    ADD SIZE CONSTANTS TO MACRO OUTPUT
C
C   Begin second code insertion
C
C===
	NBYTES = OFSIZ * OUNSIZ
	IF(NBYTES .LT. 5)GOTO 26
	IF(OSBNAM(1) .EQ. 0) GOTO 26
	CALL NUMSTG (BYTSIZ, NBYTES)
	CALL PUTMAR (EQUTAB)
	CALL PUTMAR (PRENAM)
	ISAVE = OTGNAM(3)
	OTGNAM(3) = 'S'
	CALL PUTMAR (OTGNAM)
	CALL PUTMAR (OSBNAM)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (BYTSIZ)
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	OTGNAM(3) = ISAVE
26	CONTINUE
C===
C
C  JIM TEAGUE    3/8/82    ADD SIZE CONSTANTS TO MACRO OUTPUT
C
C  end second (and last) code insertion
C
C===
	RETURN

C	THIS IS THE BEGINNING OF A BITFIELD DEFINITION LIST. THE FORMAT IS
C	'(TAB) $VIELD (TAB) PRENAM,0,<-' FOLLOWED BY THE
C	REST OF THE LINE.

30	IF (DEBUG) TYPE 520
520	FORMAT (' BITFIELD OUTPUT')
	IF (TAGNAM(2).EQ.'$') CALL PUTMAR (DOLVLD)
	IF (TAGNAM(2).EQ.'_') CALL PUTMAR (UNDVLD)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (ZRLAHY)
	CALL PUTMAR (SPCSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS THE END OF A BITFIELD DEFINITION LIST TO BE
C	OUTPUT. THE FORMAT IS '(TAB) (TAB) >' FOLLOWED BY THE
C	REST OF THE LINE.

35	IF (DEBUG) TYPE 530
530	FORMAT (' END VIELD OUTPUT')
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABRAN)
	CALL PUTMAR (TABSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS THE BEGINNING OF A CONSTANT DEFINITION LIST.
C	THE FORMAT IS '$EQULST (TAB) PRENAM\TAG,$GBL,BASE,INCREMENT,<-'
C	FOLLOWED BY THE REST OF THE LINE.

40	IF (DEBUG) TYPE 540
540	FORMAT (' CONSTANT LIST OUTPUT')
	CALL PUTMAR (EQULST)
	CALL PUTMAR (CONPRE)
	CALL PUTMAR (CONTAG)
	CALL PUTMAR (DOLGBL)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (MRBASE)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (MRINCR)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (LANHYP)
	CALL PUTMAR (SPCSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS THE END OF A CONSTANT DEFINITION LIST TO BE
C	OUTPUT. THE FORMAT IS '(TAB) (TAB) >' FOLLOWED BY THE REST OF
C	THE LINE.

45	IF (DEBUG) TYPE 550
550	FORMAT (' END CONSTANT LIST OUTPUT')
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABRAN)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS A BITFIELD DEFINITION TO BE OUTPUT. THE FORMAT IS
C	'(TAB) (TAB) <FLDNAM,SIZE,M>-' FOLLOWED BY THE REST OF
C	THE LINE.

50	IF (DEBUG) TYPE 560
560	FORMAT (' ONE BITFIELD OUTPUT')
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABLAN)
	CALL PUTMAR (FLDNAM)
	CALL PUTMAR (COMMAS)
	IF (VSIZ .EQ. 0) GOTO 52
	CALL NUMSTG (BYTSIZ, VSIZ)
	CALL PUTMAR (BYTSIZ)
52	CALL PUTMAR (COMMAS)
	CALL PUTMAR (AMASK)
	CALL PUTMAR (RANHYP)
	CALL PUTMAR (SPCSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS A CONSTANT NAME DEFINITION WITHIN A LIST. THE FORMAT
C	IS '(TAB) (TAB) <FLDNAM,VALUE>-' FOLLOWED BY THE REST OF
C	THE LINE.

60	IF (DEBUG) TYPE 570
570	FORMAT (' LIST CONSTANT OUTPUT')
	CALL PUTMAR (TABSTG)
	IF ((CONEXP) .AND. (FLDNAM (1) .EQ. 0)) GOTO 61
	CALL PUTMAR (TABLAN)
	GOTO 62
61	CALL PUTMAR (TABSTG)
62	IF ((CONEXP) .AND. (FLDNAM (1) .EQ. 0)) CALL PUTMAR (TABSTG)
	CALL PUTMAR (FLDNAM)
	IF (MVALUE (1) .EQ. 0) GOTO 65
	IF (FLDNAM (1) .NE. 0) CALL PUTMAR (COMMAS)
	IF (.NOT. CONEXP) GOTO 63
	IF (FLDNAM (1) .NE. 0) CALL PUTMAR (EXPOPN)
63	CALL PUTMAR (MVALUE)
	IF ((.NOT. ENDEXP) .AND. (CONEXP)) GOTO 67
	IF (ENDEXP) CALL PUTMAR (EXPCLO)
65	CALL PUTMAR (RANHYP)
67	CALL PUTMAR (SPCSTG)
	CALL PUTMAR (RSTLIN)
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS A SINGLE CONSTANT DEFINITION TO BE OUTPUT. THE
C	FORMAT IS '$EQU (TAB) PRENAM\TAGNAM\FLDNAM (TAB) CVALUE'
C	FOLLOWED BY THE REST OF THE LINE.

70	IF (DEBUG) TYPE 580
580	FORMAT (' SINGLE CONSTANT OUTPUT')
	CALL PUTMAR (EQUTAB)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (TAGNAM)
	CALL PUTMAR (FLDNAM)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (MVALUE)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS A POSITION MARKING DECLARATION.  ONLY THE COMMENT
C	OF THE LINE IS OUTPUT.

80	IF (DEBUG) TYPE 600
600	FORMAT (' POSITION MARK OUTPUT')
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	THIS IS REORIGINING COMMAND. THE POINTER IS RESET BY
C	A DECLARATION OF THE FORM '. = (VALUE)' FOLLOWED BY THE
C	REST OF THE LINE.

90	IF (DEBUG) TYPE 610
610	FORMAT (' REORIGIN OUTPUT')
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (DOTEQS)
	CALL NUMSTG (OFFSET, BLFOFS)
	CALL PUTMAR (OFFSET)
	CALL PUTMAR (SPCSTG)
	INBUF (PTR) = INBUF (1) - PTR + 1
	CALL PUTMAR (INBUF (PTR))
	IF (DEBUG) TYPE 300, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	RETURN

C	ERROR REPORTING

100	TYPE 2000
2000	FORMAT (' INVALID OUTPUT LINE TYPE')
	RETURN
	END

C	REVISION HISTORY:
C		23-03-77	CP	WHEN OUTPUTTING BITFIELD MASK, 
C					AMOUNT TO SHIFT BITS IS VOFSET +
C					VSIZ, NOT VOFSET + 1.
C
C		04-04-77	TC	CONDITIONALIZE OUTPUT OF ")" IN CONSTANTS
C					TO AVOID PREMATURLY CLOSING IN THE MIDDLE OF
C					MULTI-LINE CONSTANTS
C
C		22-04-77	TC	OUTPUT COMMENTS FROM VIELD
C					AND VIELDE (BEGINNING
C					AND END OF BITFIELD DEFINITION
C					LIST).

	SUBROUTINE BDOUTL (PTR)

C	OUTPUTS A DEFINITION TO THE BLISS FILE. THE ARGUMENT
C	PTR POINTS TO THE LOGICAL END OF LINE IN THE INPUT
C	LINE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER PTR, LOCAL

	IF (DEBUG) TYPE 300
300	FORMAT (' IN BLISS OUTPUT')
	IF (LINTYP .EQ. FIELD) GOTO 10
	IF (LINTYP .EQ. SBFLD) GOTO 20
	IF (LINTYP .EQ. VIELD) GOTO 30
	IF (LINTYP .EQ. VIELDE) GOTO 35
	IF (LINTYP .EQ. CONST) GOTO 40
	IF (LINTYP .EQ. CONSTE) GOTO 45
	IF (LINTYP .EQ. BITFNM) GOTO 50
	IF (LINTYP .EQ. CONSTN) GOTO 60
	IF (LINTYP .EQ. SCONST) GOTO 70
	IF (LINTYP .EQ. MARKPT) GOTO 80
	IF (LINTYP .EQ. ORIGIN) GOTO 90
	IF (LINTYP .NE. LABELN) GOTO 100

C	THIS IS A LABEL DEFINITION TO BE OUTPUT. THE FORMAT IS
C	'LITERAL (TAB) PRENAM\CTAGNAM\FLDNAM (TAB) = (SPACE) BYTOFF;
C	 LITERAL (TAB) PRENAM\KTAGNAM\FLDNAM (TAB) = (SPACE) BYTOFF;'
C	FOLLOWED BY THE REST OF THE LINE.  HERE CTAGNAM IS THE
C	TAGNAM WITH THE SECOND CHARACTER CHANGED TO A 'C',
C	KTAGNAM IS THE TAGNAM WITH THE SECOND CHARACTER CHANGED TO
C	A 'K', AND BYTOFF IS THE CURRENT OFFSET IN THE STRUCTURE
C	EXPRESSED IN BYTES.

	IF (DEBUG) TYPE 400
400	FORMAT (' LABEL OUTPUT')
	TAGNAM (3) = 'C'
	CALL PUTBLI (LITTAB)
	CALL PUTBLI (PRENAM)
	CALL PUTBLI (TAGNAM)
	CALL PUTBLI (FLDNAM)
	CALL PUTBLI (TABEQS)
	CALL NUMSTG (BYTSIZ, FOFSET)
	CALL PUTBLI (BYTSIZ)
	CALL PUTBLI (SEMSPC)
	CALL OUTBLI
	TAGNAM (3) = 'K'
	CALL PUTBLI (LITTAB)
	CALL PUTBLI (PRENAM)
	CALL PUTBLI (TAGNAM)
	CALL PUTBLI (FLDNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (BYTSIZ)
	CALL PUTBLI (SEMSPC)
	CALL PUTBLI (TABSTG)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
250	FORMAT (' ',90A1)
	CALL OUTBLI
	RETURN

C	THIS IS A FIELD DEFINITION TO BE OUTPUT. THE FORMAT
C	IS 'MACRO (TAB) PRENAM\TAGNAM\FLDNAM (TAB) = (SPACE)'
C	FOLLOWED BY A BLISS MACRO DEFINITION. THERE ARE FOUR
C	VALUES, THE OFFSET, POSITION, SIZE, AND SIGN. FINALLY THERE
C	IS A '%; (SPACE)' FOLLOWED BY THE REST OF THE LINE.

10	IF (DEBUG) TYPE 410
410	FORMAT (' FIELD OUTPUT')
	IF (FLDNAM (1) .EQ. 0) RETURN
	CALL NUMSTG (OFFSET, FOFSET)
	LOCAL = OBBITS * OFSIZ
	CALL NUMSTG (BLSSIZ, LOCAL)
	CALL PUTBLI (MACTAB)
	CALL PUTBLI (PRENAM)
	CALL PUTBLI (OTGNAM)
	CALL PUTBLI (OSBNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (OFFSET)
	CALL PUTBLI (COMMAS)
	CALL PUTBLI (ZEROSG)
	CALL PUTBLI (COMMAS)

C	SEE WHETHER THE SIZE OF THIS FIELD IS LARGER THAN 32 BITS.
C	IF SO, OUTPUT A ZERO.

	IF ((OFSIZ * OUNSIZ) .LT. 5) GOTO 11
	CALL PUTBLI (ZEROSG)
	GOTO 12
11	CALL PUTBLI (BLSSIZ)
12	CALL PUTBLI (COMMAS)
	CALL PUTBLI (OASIGN)
	CALL PUTBLI (PCTSEM)
	CALL EXCCMT (RSTLIN, 1)
	CALL PUTBLI (RSTLIN)
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI

C	IF THE SIZE OF THE FIELD DEFINED IS GREATER THAN 4 BYTES,
C	A SECOND BLISS DECLARATION IS OUTPUT. THIS IS A LITERAL
C	DEFINITION OF THE LENGTH OF THE FIELD. THE FORMAT IS
C	'LITERAL (TAB) PRENAM\TAGNAM (CHANGED TO S)\FLDNAM
C	(TAB) = (SPACE)' FOLLOWED BY THE LENGTH OF THE FIELD IN
C	BYTES AND A SEMI-COLON.

	LOCAL = OFSIZ * OUNSIZ
	IF (LOCAL .LT. 5) GOTO 13
	CALL NUMSTG (BYTSIZ, LOCAL)
	IF (DEBUG) TYPE 420
420	FORMAT (' FIELD LENGTH OUTPUT')
	CALL PUTBLI (LITTAB)
	CALL PUTBLI (PRENAM)
	OTGNAM (3) = 'S'
	CALL PUTBLI (OTGNAM)
	CALL PUTBLI (OSBNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (BYTSIZ)
	CALL PUTBLI (SEMSPC)
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
13	RETURN

C	THIS IS A SUBFIELD DEFINITION TO BE OUTPUT. IT IS EXACTLY
C	LIKE A FIELD EXCEPT THAT THE OFFSET FIELD IS DETERMINED
C	BY THE SOFSET VARIABLE INSTEAD OF THE FOFSET VARIABLE
C	AND THE NAMES OF THE STORED VARIABLES ARE DIFFERENT.

20	IF (DEBUG) TYPE 430
430	FORMAT (' SUBFIELD OUTPUT')
	IF (OSBNAM (1) .EQ. 0) RETURN
	IF (FLDNAM (1) .EQ. 0) RETURN
	CALL NUMSTG (OFFSET, BLFOFS)
	LOCAL = OBBITS * OFSIZ
	CALL NUMSTG (BLSSIZ, LOCAL)
	CALL PUTBLI (MACTAB)
	CALL PUTBLI (PRENAM)
	CALL PUTBLI (OTGNAM)
	CALL PUTBLI (OSBNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (OFFSET)
	CALL PUTBLI (COMMAS)
	CALL PUTBLI (ZEROSG)
	CALL PUTBLI (COMMAS)

C	SEE WHETHER THE SIZE OF THIS FIELD IS GREATER THAN 32
C	BITS. IF SO, JUST OUTPUT A ZERO IN THE SIZE FIELD.

	IF ((OFSIZ * OUNSIZ) .LT. 5) GOTO 21
	CALL PUTBLI (ZEROSG)
	GOTO 22
21	CALL PUTBLI (BLSSIZ)
22	CALL PUTBLI (COMMAS)
	CALL PUTBLI (OASIGN)
	CALL PUTBLI (PCTSEM)
	CALL EXCCMT (RSTLIN, 1)
	CALL PUTBLI (RSTLIN)
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI

C	IF THE SIZE OF THE SUBFIELD DEFINED IS GREATER THAN 4 BYTES,
C	A SECOND BLISS DECLARATION IS OUTPUT. THIS IS A LITERAL
C	DEFINITION OF THE LENGTH OF THE FIELD. THE FORMAT IS
C	'LITERAL (TAB) PRENAM\OTGNAM (CHANGED TO S)\OSBNAM
C	(TAB) = (SPACE)' FOLLOWED BY THE LENGTH OF THE FIELD IN
C	BYTES AND A SEMI-COLON.

	LOCAL = OFSIZ * OUNSIZ
	IF (LOCAL .LT. 5) GOTO 25
	CALL NUMSTG (BYTSIZ, LOCAL)
	IF (DEBUG) TYPE 420
	CALL PUTBLI (LITTAB)
	CALL PUTBLI (PRENAM)
	OTGNAM (3) = 'S'
	CALL PUTBLI (OTGNAM)
	CALL PUTBLI (OSBNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (BYTSIZ)
	CALL PUTBLI (SEMSPC)
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
25	RETURN

C	THIS IS THE BEGINNING OF A BITFIELD DEFINITION LIST.
C	ONLY THE COMMENT PART IS PRINTED.

30	IF (DEBUG) TYPE 435
435	FORMAT (' BITFIELD OUTPUT')
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	THIS IS THE END OF A BITFIELD DEFINITION LIST.
C	ONLY THE COMMENT PART IS PRINTED.

35	IF (DEBUG) TYPE 437
437	FORMAT (' BITFIELD OUTPUT')
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	THIS IS THE BEGINNING OF A CONSTANT DEFINITION LIST. THE
C	THIS IS THE BEGINNING OF A CONSTANT DEFINITION LIST. THE
C	FORMAT IS A LINE CONTAINING ONLY THE WORD 'LITERAL'; THEN
C	A LINE CONTAINING '$EQULST (TAB) ( PRENAM\CONTAG (COMMA) GBL
C	(COMMA) BASE (COMMA) INCREMENT'
C	FOLLOWED BY THE REST OF THE LINE.

40	IF (DEBUG) TYPE 440
440	FORMAT (' CONSTANT LIST OUTPUT')
	CALL PUTBLI (LITTAB)
	CALL OUTBLI
	CALL PUTBLI (EQULST)
	CALL PUTBLI (OPAREN)
	CALL PUTBLI (CONPRE)
	CALL PUTBLI (CONTAG)
	CALL PUTBLI (COMGBL)
	CALL PUTBLI (BLBASE)
	CALL PUTBLI (COMMAS)
	CALL PUTBLI (BLINCR)
	CALL PUTBLI (SPCSTG)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	THIS IS THE END OF A CONSTANT DEFINITION LIST TO BE OUTPUT.

45	IF (DEBUG) TYPE 450
450	FORMAT (' CONSTANT LIST END')
	CALL PUTBLI (TABPRN)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	THIS IS A BITFIELD DEFINITION TO BE OUTPUT. THE FORMAT
C	IS 'MACRO (TAB) PRENAM\TAGNAM\FLDNAM (TAB) = (SPACE)'
C	OFFSET FOR STARTING VIELD BYTE, POSITION OF THIS BITFIELD,
C	SIZE OF THIS BITFIELD, AND SIGN, FOLLOWED BY 'PERCENT
C	SEMI-COLON' AND THE REST OF THE LINE.

50	IF (DEBUG) TYPE 500
500	FORMAT (' ONE BITFIELD OUTPUT')
	IF (FLDNAM (1) .EQ. 0) GOTO 51
	CALL NUMSTG (OFFSET, BLFOFS)
	CALL NUMSTG (BYTSIZ, VOFSET)
	IF (VSIZ .EQ. 0) VSIZ = 1
	CALL NUMSTG (BLSSIZ, VSIZ)
	CALL PUTBLI (MACTAB)
	CALL PUTBLI (PRENAM)
	CALL PUTBLI (TAGNAM)
	CALL PUTBLI (FLDNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (OFFSET)
	CALL PUTBLI (COMMAS)
	CALL PUTBLI (BYTSIZ)
	CALL PUTBLI (COMMAS)
	CALL PUTBLI (BLSSIZ)
	CALL PUTBLI (COMMAS)
	CALL PUTBLI (ASIGN)
	CALL PUTBLI (PCTSEM)
	GOTO 53

51	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)

53	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI

C	IF THE MASK FOR THIS FIELD IS REQUIRED, A LITERAL
C	DECLARATION IS OUTPUT FOR THE MASK.

	IF ((.NOT. SMASK) .AND. (.NOT. VMASK)) RETURN
	IF (FLDNAM(1) .EQ. 0) RETURN
	IF (DEBUG) TYPE 510
510	FORMAT (' LITERAL MASK OUTPUT')
	LOCAL = VOFSET + VSIZ
	CALL NUMSTG (BLSSIZ, LOCAL)
	CALL PUTBLI (LITTAB)
	CALL PUTBLI (PRENAM)
	TAGNAM (3) = 'M'
	CALL PUTBLI (TAGNAM)
	TAGNAM (3) = 'V'
	CALL PUTBLI (FLDNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (ONESHF)
	CALL PUTBLI (BLSSIZ)
	CALL PUTBLI (SPHYSP)
	CALL PUTBLI (ONESHF)
	CALL PUTBLI (BYTSIZ)
	CALL PUTBLI (SEMSPC)
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	THIS IS A CONSTANT NAME DEFINITION WITHIN A LIST.
C	THE FORMAT IS '(TAB) (COMMA) FLDNAM (COMMA) BVALUE'
C	 FOLLOWED BY THE REST OF THE LINE.

60	IF (DEBUG) TYPE 520
520	FORMAT (' CONSTANT NAME OUTPUT')
	CALL PUTBLI (TABSTG)
	IF ((CONEXP).AND.(FLDNAM(1).EQ.0)) GOTO 67
	CALL PUTBLI(COMMAS)
	CALL PUTBLI(OPAREN)
	CALL PUTBLI(FLDNAM)
	CALL PUTBLI(COMMAS)
65	CALL PUTBLI(BVALUE)
	IF (ENDEXP .OR. (.NOT. CONEXP))
	1   CALL PUTBLI(CPAREN)
	CALL PUTBLI(SPCSTG)
	CALL PUTBLI(TABSTG)
	CALL EXCCMT(RSTLIN,1)
	CALL PUTBLI(RSTLIN)
	IF (DEBUG) TYPE 250, (BLIBUF(I), I = 2,BLIBUF(1)+1)
	CALL OUTBLI
	RETURN

67	CALL PUTBLI(TABSTG)
	GOTO 65


C	THIS IS A SINGLE CONSTANT DEFINITION TO BE OUTPUT.
C	THE FORMAT IS 'LITERAL (TAB) (TAB) = (SPACE)' FOLLOWED
C	BY THE VALUE OF THE CONSTANT, THEN '; (SPACE)' AND
C	THE REST OF THE LINE.

70	IF (DEBUG) TYPE 600
600	FORMAT (' SINGLE CONSTANT OUTPUT')
	CALL PUTBLI (LITTAB)
	CALL PUTBLI (PRENAM)
	CALL PUTBLI (TAGNAM)
	CALL PUTBLI (FLDNAM)
	CALL PUTBLI (TABEQS)
	CALL PUTBLI (BVALUE)
	CALL PUTBLI (SEMSPC)
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	THIS IS A POSITION MARKING DECLARATION. ONLY THE COMMENT
C	PORTION OF THE LINE IS OUTPUT.

80	IF (DEBUG) TYPE 610
610	FORMAT (' POSITION MARK OUTPUT')
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	THIS IS REORIGINING COMMAND. ONLY THE COMMENT PORTION OF
C	THE LINE IS OUTPUT.

90	IF (DEBUG) TYPE 620
620	FORMAT (' REORIGIN OUTPUT')
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL PUTBLI (TABSTG)
	CALL EXCCMT (INBUF, PTR)
	CALL PUTBLI (INBUF (PTR))
	IF (DEBUG) TYPE 250, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN

C	ERROR REPORTING

100	TYPE 2000
2000	FORMAT (' INVALID OUTPUT LINE TYPE')
	RETURN
	END

	SUBROUTINE OUTFLD

C	OUTPUTS A FIELD OR SUBFIELD DEFINITION. IF THE IMPLICIT ARGUMENT
C	BLKOUT IS TRUE, OUTPUTS A '.BLK' ALLOCATION TO THE MARS FILE.
C	OTHERWISE, OUTPUTS THE FIELD WITHOUT THE ALLOCATION.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	IF (DEBUG) TYPE 490
490	FORMAT (' IN OUTFLD')
	CALL MDOUTL (INPTR)
	CALL BDOUTL (INPTR)
	IF (LINTYP .NE. FIELD) GOTO 10
	IF (DEBUG) TYPE 500, FOFSET, OUNSIZ, OFSIZ, BLFOFS
500	FORMAT (' FOFSET ',I3,' OUNSIZ ',I3,' OFSIZ ',I3,' BLFOFS ',I3)
	BOFSET = FOFSET
	FOFSET = FOFSET + OUNSIZ * OFSIZ
	OSBNAM (1) = 0
	LASLIN = FIELD
	RETURN

10	IF (LINTYP .NE. SBFLD) GOTO 20
	IF (DEBUG) TYPE 510, FOFSET, SOFSET, LSBSIZ, BLFOFS
510	FORMAT (' FOFSET ',I3,' SOFSET ',I3,' LSBSIZ ',I3,' BLFOFS ',I3)
	SOFSET = SOFSET + LSBSIZ
	LASLIN = SBFLD
	OSBNAM (1) = 0

20	RETURN
	END

	SUBROUTINE OUTBCL

C	OUTPUTS A SINGLE LINE IN A CONSTANT DEFINITION LIST. THE
C	LINE IS BLANK OR HAS ONLY COMMENTS. FOR MARS, IT MUST BEGIN
C	WITH A HYPHEN, FOR BLISS IT CAN GO OUT AS IS.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	CALL PUTMAR (HYPHEN)
	CALL PUTMAR (INBUF (1))
	IF (DEBUG) TYPE 500, (MARBUF (I), I = 2, MARBUF (1) + 1)
500	FORMAT (' ',90A1)
	CALL OUTMAR

C	NOW OUTPUT THE BLISS LINE

	CALL EXCCMT (INBUF, 1)
	CALL PUTBLI (INBUF (1))
	IF (DEBUG) TYPE 500, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI

	RETURN
	END

C	REVISION HISTORY:
C		22-03-77	CP	IF TMP FILE FLAG IS TRUE, OUTPUT
C					COUNT AS NEGATIVE ALLOCATION.

	SUBROUTINE OUTBLK (COUNT)

C	OUTPUTS A DECLARATION OF BLOCK ALLOCATION TO THE
C	TRANSLATED MARS FILE. THE ARGUMENT COUNT IS THE NUMBER
C	OF BYTES TO ALLOCATE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER COUNT, LOCAL

	IF (DEBUG) TYPE 500, COUNT
500	FORMAT (' ALLOCATING ',I3,' BLOCKS')
	LOCAL = COUNT / OUNSIZ
	IF (COUNT .NE. OUNSIZ * LOCAL) GOTO 20
	CALL NUMSTG (BYTSIZ, LOCAL)
	GOTO 25
20	CALL NUMSTG (BYTSIZ, COUNT)
	OUNTYP (2) = 'B'
25	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABSTG)
	CALL PUTMAR (DOTBLK)
	CALL PUTMAR (OUNTYP)
	CALL PUTMAR (TABSTG)
	IF (TMPOUT) CALL PUTMAR (NEGSGN)
	CALL PUTMAR (BYTSIZ)
	CALL PUTMAR (SPCSTG)
	IF (DEBUG) TYPE 510, (MARBUF (I), I = 2, MARBUF (1) + 1)
510	FORMAT (' ',90A1)
	CALL OUTMAR
	IF (.NOT. TMPOUT) BLFOFS = BLFOFS + COUNT
	RETURN
	END

C	REVISION HISTORY:
C		22-03-77	CP	IF OUTPUTTING TO TMP FILE, CALL TMPWRT
C					INSTEAD OF OUTMAR AND OUTBLI.

	SUBROUTINE OUT2LN

C	THIS ROUTINE SIMPLY OUTPUTS A SINGLE LINE TO BOTH OUTPUT
C	FILES. THE LINE IS IDENTICAL TO THE INPUT LINE IN THE MARS
C	FILE, AND HAS SEMI-COLONS CHANGED TO EXCLAMATION POINTS
C	IN THE BLISS FILE.
C
C	IF OUTPUTTING TO THE TMP FILE, JUST OUTPUT THE LINE ONCE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER I

C	OUTPUT THE MARS LINE.

	IF (TMPOUT) GOTO 20
	CALL PUTMAR (INBUF)
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 10
	RETURN

C	NOW THE BLISS LINE.

10	I = 1
	CALL EXCCMT (INBUF, I)
	CALL PUTBLI (INBUF)
	CALL OUTBLI
	RETURN

20	CALL TMPWRT
	RETURN

	END

C	REVISION HISTORY:
C		23-03-77	CP	OUTPUT SUFNAM INSTEAD OF SUFDEF.
C
C		19-01-78	TC	OUTPUT SUFNAM AS A FINAL ARGUMENT
C					TO DEFEND.
C
C		18-02-80		TIM HALVORSEN
C					OUTPUT $ ON FRONT OF MACRO NAME
C					ONLY IF SYSTEM STRUCTURE ($STRUCT)

	SUBROUTINE OUTSTE 

C	FORMATS AND OUTPUTS THE END MACRO DEFINITIONS FOR A
C	STRUCTURE TO MARS. THEN FORMATS AND OUTPUTS ONLY
C	THE COMMENTS FROM THE LINE TO BLISS.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

C	IF (DEBUG) TYPE 400
400	FORMAT (' IN OUTSTE')
	MARBUF (1) = 1
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 5
	RETURN

5	CALL PUTMAR (DEFEND)
C	IF (DEBUG) TYPE 410, (DEFEND (I), I = 2, DEFEND (1) + 1)
410	FORMAT (' ',90A1)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (DOLGBL)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (SUFNAM)
	INBUF (INPTR) = INBUF (1) - INPTR + 1
	CALL PUTMAR (INBUF (INPTR))
C	IF (DEBUG) TYPE 410, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 10
	RETURN

10	MARBUF (1) = 1
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 20
	RETURN

20	CALL PUTMAR (ENDMAC)
C	IF (DEBUG) TYPE 410, (ENDMAC (I), I = 2, ENDMAC (1) + 1)
	IF (TAGNAM (2) .EQ. '$') CALL PUTMAR (DOLLAR)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (SUFNAM)
	IF (DEBUG) TYPE 410, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 30
	RETURN

30	CALL EXCCMT (INBUF, INPTR)
	CALL PUTBLI (INBUF (INPTR))
	CALL OUTBLI
	RETURN
	END

C	REVISION HISTORY:
C		23-03-77	CP	OUTPUT SUFNAM INSTEAD OF SUFDEF.
C
C		18-02-80		TIM HALVORSEN
C					OUTPUT $ ON FRONT OF MACRO NAME
C					ONLY IF SYSTEM STRUCTURE ($STRUCT)

	SUBROUTINE OUTSTR

C	FORMATS THE MACRO DEFINITION OF A DATA STRUCTURE AND
C	OUTPUTS IT TO THE MARS FILE. FORMATS AND OUTPUTS THE COMMENT
C	PART OF THE LINE TO THE BLISS FILE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

C	FIRST OUTPUT THREE LINES FOR MARS

C	IF (DEBUG) TYPE 400
400	FORMAT (' IN OUTSTR')
	CALL PUTMAR (DOTMAC)
	IF (TAGNAM (2) .EQ. '$') CALL PUTMAR (DOLLAR)
C	IF (DEBUG) TYPE 410, (DOTMAC (I), I = 2, DOTMAC (1) + 1)
	INPTR = INPTR + 1
410	FORMAT (' ',90A1)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (SUFNAM)
C	IF (DEBUG) TYPE 410, (PRENAM (I), I = 2, PRENAM (1) + 1)
	CALL PUTMAR (DOLGBL)
C	IF (DEBUG) TYPE 410, (DOLGBL (I), I = 2, DOLGBL (1) + 1)
	INBUF (INPTR) = INBUF (1) - INPTR + 1
	CALL PUTMAR (INBUF (INPTR))
	IF (DEBUG) TYPE 410, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 10
	RETURN

10	MARBUF (1) = 1
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 20
	RETURN

20	CALL PUTMAR (DEFINI)
C	IF (DEBUG) TYPE 410, (DEFINI (I), I = 2, DEFINI (1) + 1)
	CALL PUTMAR (PRENAM)
	CALL PUTMAR (DOLGBL)
C	IF (DEBUG) TYPE 410, (MARBUF (I), I = 2, MARBUF (1) + 1)
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 30
	RETURN

30	MARBUF (1) = 1
	CALL OUTMAR
	IF (.NOT. ERROUT) GOTO 40
	RETURN

40	CALL PUTBLI (EXCLSP)
	CALL PUTBLI (PRENAM)
	CALL PUTBLI (SUFNAM)
	CALL PUTBLI (TABSTG)
	CALL EXCCMT (INBUF, INPTR)
	CALL PUTBLI (INBUF (INPTR))
	IF (DEBUG) TYPE 410, (BLIBUF (I), I = 2, BLIBUF (1) + 1)
	CALL OUTBLI
	RETURN
	END

	SUBROUTINE OUTCNL

C	OUTPUTS THE CLOSING OF A CONSTANT NAME DEFINITION LIST
C	AND THE BEGINNING OF ANOTHER NAMED THE SAME AS THE LAST ONE.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	IF (DEBUG) TYPE 300
300	FORMAT (' CONSTANT LIST REPEAT')

	CALL PUTMAR (TABSTG)
	CALL PUTMAR (TABRAN)
	CALL OUTMAR

	CALL PUTMAR (EQULST)
	CALL PUTMAR (CONPRE)
	CALL PUTMAR (CONTAG)
	CALL PUTMAR (DOLGBL)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (MRINCR)
	CALL PUTMAR (COMMAS)
	CALL PUTMAR (LANHYP)
	CALL OUTMAR

	RETURN
	END

	SUBROUTINE TMPWRT

C	THIS IS A NEW ROUTINE FOR VERSION 1.3.
C
C	IT OUTPUTS A LINE FROM THE SOURCE FILE TO THE TMP FILE.
C	THE LINE IS IDENTICAL TO THE SOURCE LINE, EXCEPT THAT
C	A LEADING MINUS HAS BEEN CHANGED TO A PLUS IN
C	THE CASE THAT THE LINE IS A FIELD DEFINITION.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	WRITE (TMP) INBUF (1), (INBUF (I), I = 2, INBUF (1) + 1)
	RETURN
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C	REVISION HISTORY:
C		22-03-77	CP	ADD NEGSGN FOR NEGATIVE POSITIONING.
C
C		29-06-77	TC	CHANGED STRING FOR DOLBYT FROM
C					'$BYTEPOSITION' TO '$BYTEOFFSET'
C					(2.4)
C
C		18-02-80		TIM HALVORSEN
C					REMOVED $ FROM DOLMAC AND ADDED NEW
C					STRING DOLLAR AND UNDVLD


	SUBROUTINE INISTG

C	THIS ROUTINE INITIALIZES A SET OF STRINGS THAT ARE USED
C	OVER AND OVER AGAIN IN OUTPUT LINES FOR THE BLISS AND MARS
C	TRANSLATED FILES.

C	EACH CALL TO LITSTG CONVERTS A STRING LITERAL INTO A COUNTED
C	STRING THAT IS STORED IN THE ARRAY LISTED AS THE FIRST
C	PARAMETER.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	CALL LITSTG (DOTMAC, '	.MACRO	', 8)
	CALL LITSTG (DOLLAR, '$', 1)
	CALL LITSTG (DOTBLK, '	.BLK', 5)
	CALL LITSTG (DOLGBL, ',$GBL', 5)
	CALL LITSTG (DEFINI, '	$DEFINI	', 9)
	CALL LITSTG (DOLDEF, '$DEF	', 5)
	CALL LITSTG (DEFEND, '	$DEFEND	', 9)
	CALL LITSTG (ENDMAC, '	.ENDM	', 7)
	CALL LITSTG (SUFDEF, 'DEF', 3)
	CALL LITSTG (AMASK, 'M', 1)
	CALL LITSTG (UNITYP, 'L', 1)
	CALL LITSTG (TABSTG, '	', 1)
	CALL LITSTG (SPCSTG, ' ', 1)
	CALL LITSTG (DOLVLD, '	$VIELD	', 8)
	CALL LITSTG (UNDVLD, '	_VIELD	', 8)
	CALL LITSTG (ZRLAHY, '0,<-', 4)
	CALL LITSTG (TABRAN, '	>', 2)
	CALL LITSTG (EQULST, '$EQULST ', 8)
	CALL LITSTG (EQUTAB, '$EQU	', 5)
	CALL LITSTG (COMMAS, ',', 1)
	CALL LITSTG (LANHYP, '<-', 2)
	CALL LITSTG (TABLAN, '	<', 2)
	CALL LITSTG (RANHYP, '>-', 2)
	CALL LITSTG (LITTAB, 'LITERAL	', 8)
	CALL LITSTG (TABEQS, '	= ', 3)
	CALL LITSTG (SEMSPC, '; ', 2)
	CALL LITSTG (MACTAB, 'MACRO		', 7)
	CALL LITSTG (ZEROSG, '0', 1)
	CALL LITSTG (PCTSEM, '%; ', 3)
	CALL LITSTG (ONESHF, '1^', 2)
	CALL LITSTG (SPHYSP, ' - ', 3)
	CALL LITSTG (HYPHEN, '-', 1)
	CALL LITSTG (OUNTYP, 'B', 1)
	CALL LITSTG (COMGBL, ',GBL,', 5)
	CALL LITSTG (TABPRN, '	); ', 4)
	CALL LITSTG (TABOPR, '	(', 2)
	CALL LITSTG (CPRCOM, '),', 2)
	CALL LITSTG (CPAREN, ')', 1)
	CALL LITSTG (DOLBIT, '$BITPOSITION', 12)
	CALL LITSTG (DOLBYT, '$BYTEOFFSET', 11)
	CALL LITSTG (DOLFLD, '$FIELDWIDTH', 11)
	CALL LITSTG (EXPOPN, '<', 1)
	CALL LITSTG (EXPCLO, '>', 1)
	CALL LITSTG (OPAREN, '(', 1)
	CALL LITSTG (EXCLSP, '!...$', 5)
	CALL LITSTG (DOTEQS, '. = ', 4)
	CALL LITSTG (NEGSGN, '-', 1)
	RETURN
	END

	SUBROUTINE CMPSTG (STGONE, STGTWO)

C	COMPARES TWO COUNTED STRINGS. RETURNS A .TRUE. IN STGEQL IF
C	THEY MATCH EXACTLY. OTHERWISE RETURNS A .FALSE. IN STGEQL.

C	STGTWO IS THE CONTROL STRING, I.E., HAS A LENGTH COUNT
C	AS LONG AS THE STRING MUST BE TO MATCH.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER STGONE (*), STGTWO (*)

C	IF (DEBUG) TYPE 1000, (STGONE (I), I = 2, STGONE (1) + 1),
C	1	(STGTWO (I), I = 2, STGTWO (1) + 1)
1000	FORMAT (' STRINGS ARE ',40A1)

	DO 10 I = 1, STGTWO (1) + 1
	IF (STGONE (I) .EQ. STGTWO (I)) GOTO 10
	STGEQL = .FALSE.
	RETURN
10	CONTINUE
	STGEQL = .TRUE.
	RETURN
	END


	SUBROUTINE MOVSTG (SRCSTG, DSTSTG)

C	MOVES ONE STRING INTO ANOTHER LOCATION. THE FIRST
C	ARGUMENT IS THE SOURCE STRING ADDRESS, THE SECOND ARGUMENT
C	THE DESTINATION STRING ADDRESS.

C	THE NUMBER OF LOCATIONS MOVED IS THE COUNT STORED IN THE
C	FIRST LOCATION OF THE SOURCE STRING PLUS 1

	INTEGER SRCSTG(*), DSTSTG(*)

	DO 10 I = 1, SRCSTG (1) + 1
	DSTSTG (I) = SRCSTG (I)
10	CONTINUE
	END

C	REVISION HISTORY:
C		22-03-77	CP	INITIALIZE TMP FILE CONTEXT.
C					CHANGE INITIALIZATION OF CONTEXT
C					ARRAY SO THAT THE FIFTH FIELD IS
C					A NEGATIVE ONE IF NO MARK HAS BEEN
C					SET FOR THIS CONTEXT POSITION.
C					VARIABLES.
C
C		20-04-77	TC	CHANGE INIT. OF CONTEXT ARRAY
C					SO THAT THE NINTH (RATHER
C					THAN THE FIFTH) FIELD IS -1 IF NO
C					MARK HAS BEEN SET FOR THIS CONTEXT
C					POSITION.

	SUBROUTINE INISTR

C	INITIALIZES VARIABLES FOR A NEW STRUCTURE DECLARATION.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

C	INITIALIZE TMP FILE CONTEXT VALUES.

	TMPIN = .FALSE.
	TMPOUT = .FALSE.

C	INITIALIZE EACH CONTEXT FIELD.

	BLFOFS = 0
	SOFSET = 0
	FOFSET = 0
	BOFSET = 0
	LFDSIZ = 0
	LSBSIZ = 0

C	INITIALIZE THE SAVED CONTEXT ARRAY.

	DO 10 I = 1,10
	CONTEX (9, I) = -1
10	CONTINUE

C	INITIALIZE THE MAXIMUM VALUES TO ZERO

	DO 20 I = 1,8
	CONTEX (I, 11) = 0
20	CONTINUE

C	INITIALIZE THE FIELD NAME AND TAG NAME

	FLDNAM (1) = 0
	TAGNAM (1) = 3
	TAGNAM (2) = '$'
	TAGNAM (4) = '_'

C	INITIALIZE LINE TYPE VARIABLES

	LASLIN = 0
	FLDLAS = .FALSE.

	RETURN
	END

	SUBROUTINE INIFLD

C	INITIALIZES THE ARGUMENT DEFAULTS FOR FIELD AND SUBFIELD
C	DEFINITIONS.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	UNITYP (2) = 'L'
	TAGNAM (3) = 'L'
	FLDNAM (1) = 0
	UNISIZ = 4
	FSIZ = 1
	BLBITS = 32
	FSIGN = 0
	ASIGN (1) = 1
	ASIGN (2) = '0'
	RETURN
	END

	SUBROUTINE SAVSBA

C	SAVES SUBFIELD NAME, TAGNAME, UNIT TYPE, AND UNIT SIZE
C	SO THAT THE SUBFIELD DEFINITION CAN BE OUTPUT
C	PARTWAY THROUGH THE PROCESSING OF THE NEXT SUBFIELD.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	DO 10 I = 1, FLDNAM (1) + 1
	OSBNAM (I) = FLDNAM (I)
10	CONTINUE

	DO 20 I = 1, TAGNAM (1) + 1
	OTGNAM (I) = TAGNAM (I)
20	CONTINUE

	DO 30 I = 1, UNITYP (1) + 1
	OUNTYP (I) = UNITYP (I)
30	CONTINUE

	OFSIZ = FSIZ
	OUNSIZ = UNISIZ

	OASIGN (1) = ASIGN (1)
	OASIGN (2) = ASIGN (2)

	OBBITS = BLBITS

	RETURN
	END

	SUBROUTINE CHKALC

C	CHECKS TO SEE WHETHER THE TOTAL ALLOCATION OF
C	BYTES IN THE MARS OUTPUT FILE IS EQUAL TO THE ACTUAL
C	FIELD OFFSET. THIS DISCREPANCY OCCURS WHEN A SET OF
C	SUBFIELDS DOES NOT TOTAL THE AMOUNT OF SPACE PERMITTED
C	BY THE SURROUNDING FIELD.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER LOCAL

C	IF (DEBUG) TYPE 500, BLFOFS, FOFSET, SOFSET, LSBSIZ
500	FORMAT (' BLFOFS ',I3,' FOFSET ',I3,' SOFSET ',I3,' LSBSIZ ',I3)
	IF (BLFOFS .EQ. FOFSET) GOTO 30
	IF ((LASLIN .NE. SBFLD) .OR.
	1	(LSBSIZ .LE. 0)) GOTO 20
	CALL OUTBLK (LSBSIZ)
20	LOCAL = FOFSET - BLFOFS
	IF (LOCAL .GT. 0) CALL OUTBLK (LOCAL)
30	RETURN
	END

	SUBROUTINE GETREM (PTR)

C	COLLECTS THE REST OF AN INPUT LINE AFTER THE DEFINITION
C	COMPONENTS AND SAVES IT IN AN AUXILIARY BUFFER.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER PTR, LOCAL

C	IF (DEBUG) TYPE 500, (INBUF (I), I = PTR + 1, INBUF (PTR) + PTR)
500	FORMAT (' ',90A1)
C	IF (DEBUG) TYPE 510, PTR, INBUF (PTR)
510	FORMAT (' POINTER IS ',I3,', COUNT IS ',I3)
	DO 10 I = PTR, INBUF (PTR) + PTR
	LOCAL = I - PTR + 1
	RSTLIN (LOCAL) = INBUF (I)
10	CONTINUE
	RETURN
	END

	SUBROUTINE EXCCMT (BUF, PTR)

C	EXCHANGES SEMI COLONS IN A LINE FOR EXCLAMATION POINTS.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER BUF(*), PTR, LOCAL

	LOCAL = BUF (PTR) + 1
C	IF (DEBUG) TYPE 100, LOCAL
100	FORMAT (' END OF LOOP COUNT IS ',I3)
	DO 10 I = PTR + 1, BUF (PTR) + PTR
	IF (BUF (I) .NE. ';') GOTO 10
	BUF (I) = '!'
10	CONTINUE
	RETURN
	END

C	REVISION HISTORY:
C		29-06-77	TC	REPLACED THREE CALLS ON CHKMAK
C					AND ONE CALL ON MOVSTG WITH A
C					CALL ON ETOMAR. (2.4)

	SUBROUTINE CVTEXP (INPVAL, BLIDUM, MARDUM)

C	CONVERTS AN EXPRESSION FOUND AT INPVAL INTO A BLISS
C	AND A MARS EXPRESSION. THE BLISS EXPRESSION IS SAVED
C	AT BLIDUM. THE MARS EXPRESSION IS SAVED AT MARDUM.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER INPVAL (*), BLIDUM (*), MARDUM (*)
	CALL MOVSTG (INPVAL, TMPVAL)
	CALL ETOBLS (TMPVAL, BLIDUM)
	IF (BLIDUM (BLIDUM (1) + 1) .EQ. '-') 
	1	BLIDUM (1) = BLIDUM (1) - 1
C	IF (DEBUG) TYPE 500, (BLIDUM (I), I = 2, BLIDUM (1) + 1)
C	IF (DEBUG) TYPE 500, (INPVAL (I), I = 2, INPVAL (1) + 1)
500	FORMAT (' ',90A1)
	CALL ETOMAR(INPVAL,MARDUM)
C	IF (DEBUG) TYPE 500, (MARDUM (I), I = 2, MARDUM (1) + 1)
	RETURN
	END
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
C	UTILITIES FOR MDL
C
C	REVISION HISTORY:
C		22-03-77	CP	CHANGE GETLIN TO ACCEPT INPUT LINES
C					FROM THE INPUT FILE OR FROM THE TMP
C					FILE, DEPENDING UPON THE SETTING OF
C					THE FLAG TMPIN.

	SUBROUTINE GETLIN
	INCLUDE 'SRC$:MDL32CMN.CMN'
	EQUIVALENCE (INCNT,INBUF(1))
C	READS A LINE OF INPUT FILE - SETS ENDFILE IF EOF, COUNTS LINES
C
	IF (TMPIN) GOTO 300
	INPLIN = INPLIN+1
	READ(INP,200,END=99,ERR=99) (INBUF(I),I=2,81)
200	FORMAT(80A1)
	INCNT = 80
	DO 20 I=1,80
	IF(INBUF(82-I).NE.BLANK) GOTO 21
	INCNT = INCNT-1
20	CONTINUE
21	INCNT = INCNT+1
	INBUF(INCNT+2) = EOLCH
	INPTR = 2
	RETURN
99	CONTINUE
C	IF (DEBUG) TYPE 1000
1000	FORMAT (' END OF FILE')
	ENDFIL = .TRUE.
	RETURN

C	WE READ THE SIZE INTO THE TEMPORARY I2 AND THEN MOVE
C	IT INTO INBUF(1) BECAUSE OF A BUG IN THE FORTRAN-10
C	OPTIMIZER.
C
300	READ (TMP, END=399, ERR=399) I2,
	1	(INBUF (I), I = 2, I2 + 1)
	INBUF (1) = I2
	INPTR = 2
	INBUF(INCNT+2) = EOLCH
	RETURN

399	ENDFIL = .TRUE.
	RETURN

	END

C	REVISION HISTORY:
C		22-03-77	CP	ADD PLUS AND MINUS AS TOKEN TYPES.

	SUBROUTINE GETTOK
C
C	RETURNS A TOKEN - AND IDENTIFIES IT IN TOKTYP
C
	INCLUDE 'SRC$:MDL32CMN.CMN'
	INTEGER TERM(7),TTYP(7)
	EQUIVALENCE (TC,TOKSTG(1))
	DATA TERM/';',',',0,'<','>','+','-'/
	DATA NTERM,TTYP/7,SEMI,COMMA,EOL,LANGLE,RANGLE,PLUS,MINUS/
C
C
C	SKIP LEADING BLANKS OR TABS
C
	K = INPTR
	L = INBUF(1) + 1
	IF (K .GT. L) GO TO 12
	DO 10 INPTR=K,L
	IF((INBUF(INPTR).NE.BLANK).AND.(INBUF(INPTR).NE.TAB)) GOTO 12
10	CONTINUE
C
C	LINE WAS EMPTY
C
12	TC = 0
	TP = 2
15	CHAR = INBUF(INPTR)
	TOKSTG(TP) = CHAR
	TC = TC+1
	TP = TP+1
	INPTR = INPTR+1
C CHECK FOR TERMINATORS
	DO 20 I=1,NTERM
20	IF(TERM(I).EQ.CHAR) GOTO 50
	DO 22 I=1,NTERM
22	IF (TERM(I).EQ.INBUF(INPTR)) GOTO 30
	IF((INBUF(INPTR).NE.BLANK).AND.(INBUF(INPTR).NE.TAB)) GOTO 15
C
C	FINISHED , CLASSIFY STRING
C
30	IF((TOKSTG(2).GE.'A').AND.(TOKSTG(2).LE.'Z')) TOKTYP = ALPHA
	IF((TOKSTG(2).EQ.'$').OR.(TOKSTG(2).EQ.'_')) TOKTYP = ALPHA
	IF((TOKSTG(2).GE.'0').AND.(TOKSTG(2).LE.'9')) TOKTYP = NUMBER
	RETURN
50	TOKTYP = TTYP(I)
	RETURN
	END
	INTEGER FUNCTION INTVAL(S)
C
C RETURNS THE DECIMAL INTEGER VALUE OF A STRING
C
	IMPLICIT INTEGER(A-Z)
	INTEGER S(*)
	INTEGER NUM(10)
	DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
C
	X = 0
	DO 10 I = 1,S(1)
	C = S(I+1)
C TO BE INDEPENDENT OF SYSTEM COMPARE CHARS
	DO 20 N=1,10
20	IF(C.EQ.NUM(N))GOTO 30
C ILLEGAL CHAR
	INTVAL = -1
	RETURN
C
30	X = 10*X + (N-1)
10	CONTINUE
	INTVAL = X
	RETURN
	END
	SUBROUTINE GETEXP(P)
C
C	PTR -> START OF AN EXPRESSION
C	RETURN WITH IT POINTING TO THE LAST CHAR OF THE EXPRESSION
C
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
C
C GO FORWARDS UNTIL EITHER EOL, COMMA, OR ; IS SEEN
C THEN BACK UP OVER BLANKS OR TABS AND POINT TO
C THE LAST NONBLANK/NONTAB
C
	DO 10 I=P,INBUF(1)+1
	K = I
	IF((INBUF(I).EQ.';') .OR.
	1	(INBUF(I).EQ.',')) GOTO 20
10	CONTINUE
20	IF (K .EQ. P) GOTO 40
	K = K-1
	K1 = K
	DO 25 I=1,K1
	IF((INBUF(K).NE.BLANK).AND.(INBUF(K).NE.TAB)) GOTO 30
	K = K-1
25	CONTINUE
30	P = K
40	RETURN
	END

	SUBROUTINE PUTMAR(CS)
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
	INTEGER CS(*)
C
C	PUTS COUNTED STRING INTO THE BUFFER (AT THE END)
C
	K = MARBUF(1)
	L = CS(1)
	DO 10 I=1,L
10	MARBUF(K+I+1)=CS(I+1)
	MARBUF(1) = K+L
	RETURN
	END
	SUBROUTINE PUTBLI(CS)
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
	INTEGER CS(*)
C
C	PUTS COUNTED STRING INTO THE BUFFER (AT THE END)
C
	K = BLIBUF(1)
	L = CS(1)
	DO 10 I=1,L
10	BLIBUF(K+I+1)=CS(I+1)
	BLIBUF(1) = K+L
	RETURN
	END
	SUBROUTINE OUTBUF(CHN,BUF)
C	OUTPUTS BUFFER BUF
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
	INTEGER BUF(*)
C
C
	IF(BUF(1).GT.1) GOTO 20
	IF(BUF(2).NE.EOLCH) GOTO 20
	WRITE(CHN,101)
101	FORMAT()
	GOTO 30
20	WRITE(CHN,100) (BUF(I),I=2,BUF(1)+1)
100	FORMAT(1X,120A1)
30	BUF(1) = 0
	BUF(2) = EOLCH
	RETURN
	END

C
	SUBROUTINE OUTMAR
C OUTPUTS THE MARS BUFFER
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
	CALL OUTBUF(MAR,MARBUF)
	RETURN
	END

	SUBROUTINE OUTBLI
C OUTPUTS THE BLISS BUFFER
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
	CALL OUTBUF(BLI,BLIBUF)
	RETURN
	END
	INTEGER FUNCTION LASTNB(P)
C
C	RETURNS INDEX OF LAST NON-BLANK,NON-TAB BEFORE THE POINTER
C
C
	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'
C
	K = P-1
	DO 10 I=1,K
	C = INBUF(P-I+1)
	IF((C.NE.BLANK).AND.(C.NE.TAB)) GOTO 30
10	CONTINUE
30	LASTNB = P-I+1
	RETURN
	END

	INTEGER FUNCTION NEXTNB (P)

C	RETURNS THE INDEX OF THE NEXT NON-BLANK, NON-TAB
C	CHARACTER AFTER THE CURRENT CHARACTER.

	INCLUDE 'SRC$:MDL32CMN.CMN/NOLIST'

	INTEGER C

	DO 10 I = P + 1, INBUF (1) + 1
	K = I
	C = INBUF (I)
	IF ((C .NE. BLANK) .AND.
	1	(C .NE. TAB)) GOTO 20
10	CONTINUE
20	NEXTNB = K
	RETURN
	END

C
C	Version V02-001
C
C****************************************************************************
C*									    *
C*  COPYRIGHT (c) 1980                                                      *
C*  BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.			    *
C* 									    *
C*  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED  *
C*  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE  *
C*  INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER  *
C*  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY  *
C*  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY  *
C*  TRANSFERRED.							    *
C* 									    *
C*  THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE  *
C*  AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT  *
C*  CORPORATION.							    *
C* 									    *
C*  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS  *
C*  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.		    *
C*									    *
C****************************************************************************
C
	SUBROUTINE REAREND
C
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 GETIDENT,IDENT,UNBLNK,GETMARLIN

	GOTO 100

90	CALL PUTLINE(LINE(1),LINELEN)
100	IF (GETMARLIN().EQ..FALSE.) GOTO 2000
	IF (UNBLNK().EQ.';') GOTO 90
	IF (GETIDENT().EQ..FALSE.) GOTO 90
	IF (IDENT('$DEFINI',NAME).EQ..FALSE.) GOTO 90

	CALL DEFINIF
	GOTO 90

2000	CONTINUE
	RETURN
	END

	SUBROUTINE CONCAT(STRNG2,STRNG1,STRNG3)
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 STRNG1(*),STRNG2(*),STRNG3(*),STRNG4(132)
	DO 100 I=1,131
	STRNG4(I)=STRNG2(I)
	IF (STRNG4(I).EQ.0) GOTO 200
100	CONTINUE
	CALL ERRORF(2,TOOLONG)
	GOTO 600
200	DO 300 I=1,131
	STRNG3(I)=STRNG1(I)
	IF (STRNG3(I).EQ.0) GOTO 400
300	CONTINUE
	CALL ERRORF(2,TOOLONG)
	GOTO 600
400	DO 500 J=1,131
	STRNG3(I-1+J)=STRNG4(J)
	IF (STRNG3(I-1+J).EQ.0) GOTO 600
500	CONTINUE
	CALL ERRORF(2,TOOLONG)
600	RETURN
	END

	INTEGER FUNCTION LENGTH(STRNG)
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 STRNG(*)
	DO 100 LENGTH=1,132
	IF (STRNG(LENGTH).EQ.0) GOTO 200
100	CONTINUE
	CALL ERRORF(2,TOOLONG)
200	LENGTH=LENGTH-1
	RETURN
	END

	SUBROUTINE MOVNAM(STRNG1,STRNG2)
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 STRNG1(*),STRNG2(*)
	DO 100 I=1,132
	STRNG2(I)=STRNG1(I)
	IF (STRNG2(I).EQ.0) GOTO 200
100	CONTINUE
	CALL ERRORF(2,TOOLONG)
200	RETURN
	END

	FUNCTION GETNUM(FAILMODE)
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 GETNUM,GETVAL
	BYTE BINOPS(8)
	DATA BINOPS/'+','-','*','/','&','!','\','@'/
	GETNUM=.FALSE.
	NUM=0
	BEGCOL=COL
	IF (GETVAL().EQ..FALSE.) GOTO 300
	GETNUM=.TRUE.
	NUM=BINVAL
100	DO 200 I=1,8
	IF (LINE(COL).EQ.BINOPS(I)) GOTO 400
200	CONTINUE
300	RETURN
400	COL=COL+1
	IF (GETVAL().EQ..TRUE.) GOTO 500
	IF (FAILMODE.EQ.0) CALL ERRORF(3,MISSINGVALUE)
	GETNUM=.FALSE.
	COL=BEGCOL
	GOTO 300
500	GOTO (610,620,630,640,650,660,670,680),I
610	NUM=NUM+BINVAL
	GOTO 100
620	NUM=NUM-BINVAL
	GOTO 100
630	NUM=NUM*BINVAL
	GOTO 100
640	NUM=NUM/BINVAL
	GOTO 100
650	NUM=NUM.AND.BINVAL
	GOTO 100
660	NUM=NUM.OR.BINVAL
	GOTO 100
670	NUM=NUM.XOR.BINVAL
	GOTO 100
680	NUM=NUM*2**BINVAL
	GOTO 100
	END

	LOGICAL FUNCTION GETVAL*1
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 UNBLNK,TMP
	SIGN=0
	BINVAL=0
	GETVAL=.FALSE.
	IF (UNBLNK().NE.'-') GOTO 100
	SIGN=1
	COL=COL+1
100	IF (UNBLNK().NE.'+') GOTO 110
	COL=COL+1
	GOTO 100
110	IF (LINE(COL).NE.'^') GOTO 180
	IF (LINE(COL+1).NE.'X') GOTO 180
	DO 150 COL=COL+2,132
	TMP=LINE(COL)
	IF ((TMP.LE.'9').AND.(TMP.GE.'0')) GOTO 130
	IF ((TMP.GT.'F').OR.(TMP.LT.'A')) GOTO 400
	TMP=TMP-'A'+'9'+1
130	GETVAL=.TRUE.
	BINVAL=BINVAL*16+(TMP-'0')
150	CONTINUE
	GOTO 300
180	DO 200 COL=COL,132
	IF (LINE(COL).LT.'0') GOTO 400
	IF (LINE(COL).GT.'9') GOTO 400
	GETVAL=.TRUE.
	BINVAL=BINVAL*10+(LINE(COL)-'0')
200	CONTINUE
300	CALL ERRORF(4,TOOLONG)
	GETVAL=.FALSE.
400	IF (SIGN.EQ.1) BINVAL=-BINVAL
	RETURN
	END

	LOGICAL FUNCTION GETIDENT*1
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 UNBLNK,IDENT
	I=1
	GETIDENT=.FALSE.
	IF (UNBLNK().EQ.';') GOTO 400
	DO 200 COL=COL,132
	IF (LINE(COL).EQ.'.') GOTO 100
	IF (LINE(COL).EQ.'$') GOTO 100
	IF (LINE(COL).EQ.'_') GOTO 100
	IF ((LINE(COL).GE.'A').AND.(LINE(COL).LE.'Z')) GOTO 100
	IF ((LINE(COL).GE.'a').AND.(LINE(COL).LE.'z')) GOTO 100
	IF (GETIDENT.EQ..FALSE.) GOTO 400
	IF ((LINE(COL).LT.'0').OR.(LINE(COL).GT.'9')) GOTO 400
100	GETIDENT=.TRUE.
	IF (I.GE.32) GOTO 200
	NAME(I)=LINE(COL)
	I=I+1
200	CONTINUE
	CALL ERRORF(4,TOOLONG)
400	CONTINUE
	NAME(I)=0
C	TYPE 99,(NAME(K),K=1,LENGTH(NAME))
C99	FORMAT(' ID=',32A1)
	RETURN
	END

	LOGICAL FUNCTION IDENT*1(STRNG1,STRNG2)
	LOGICAL*1 STRNG1(*),STRNG2(*)
	IDENT=.FALSE.
	DO 100 I=1,132
	IF (STRNG1(I).EQ.0.AND.STRNG2(I).EQ.0) GOTO 200
	IF (STRNG1(I).NE.STRNG2(I)) GOTO 300
100	CONTINUE
200	IDENT=.TRUE.
300	RETURN
	END

	LOGICAL FUNCTION UNBLNK*1
	INCLUDE 'SRC$:MDL32CMN.CMN'
	IF (COL.GT.132) GOTO 150
	DO 100 COL=COL,132
	IF (LINE(COL).GE."11.AND.LINE(COL).LE."14) GOTO 100
	IF (LINE(COL).NE.' ') GOTO 200
100	CONTINUE
150	COL=133
200	UNBLNK=LINE(COL)
	RETURN
	END

	LOGICAL*1 FUNCTION GETMARLIN
	INCLUDE 'SRC$:MDL32CMN.CMN'
	GETMARLIN=.FALSE.
	LINE(1)=';'
	COL=1
	READ(MAR,99,END=100) LINELEN,(LINE(K),K=1,132)
99	FORMAT(Q,132A1)
	GETMARLIN=.TRUE.
100	CONTINUE
	LINE(133)=';'
C	TYPE 98,(LINE(K),K=1,133)
C98	FORMAT(1X,72A1/1X,72A1)
	RETURN
	END

	SUBROUTINE ERRORF(MSGID)
	INCLUDE 'SRC$:MDL32CMN.CMN'
C OUTPUT CONTENTS OF 'LINE' VIA PRINT
C AND ERROR MESSAGE
	TYPE 99
99	FORMAT('$%MDLFIXUP-E-')
	GOTO (1,2,3,4,5,6),MSGID
	TYPE 1000
	GOTO 200
1000	FORMAT('+error in error processing')
1	TYPE 101
	GOTO 200
101	FORMAT('+syntax error')
2	TYPE 102
	GOTO 200
102	FORMAT('+symbol or string too long')
3	TYPE 103
	GOTO 200
103	FORMAT('+missing value')
4	TYPE 104
	GOTO 200
104	FORMAT('+line too long')
5	TYPE 105
	GOTO 200
105	FORMAT('+missing close angle bracket')
6	TYPE 106
	GOTO 200
106	FORMAT('+missing E (end) statement')
200	CONTINUE
	TYPE 98,(LINE(I),I=1,LINELEN)
98	FORMAT(1X,<LINELEN>A1)
	END

	SUBROUTINE VIELDF
C	ROUTINE TO HANDLE MDL VIELD SYNTAX

	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 GETIDENT,UNBLNK,GETNUM,IDENT,GETMARLIN
	BYTE TAB5(6),EQULINE(132),SAVENAME(32)
	DATA TAB5/9,9,9,9,9,0/

	PREFIX(1)=NAME(1)
	PREFIX(2)=0
	IF (GETIDENT().EQ..FALSE.) GOTO 2000
	CALL CONCAT(PREFIX,NAME,PREFIX)
	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	BIT=0
	IF (GETNUM(0)) BIT=NUM
	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.'<') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.'-') GOTO 2000
	COL=COL+1
	IF (UNBLNK().EQ.';') GOTO 700
2000	CALL ERRORF(1,SYNTAX)
700	IF (GETMARLIN().NE..TRUE.) GOTO 1500
	IF (UNBLNK().EQ.'>') GOTO 1600
	IF (UNBLNK().EQ.'-') THEN
	   COL=COL+1
	   IF (UNBLNK().NE.';') GOTO 2000
	   LINE(LINELEN+1)=0
	   CALL CONCAT(LINE(COL),TAB5,EQULINE)
	   CALL PUTLINE(EQULINE,LENGTH(EQULINE))
	   GOTO 700
	ENDIF
	IF (UNBLNK().NE.'<') GOTO 2000
	COL=COL+1
C
C SET UP COMMENT COPY FOR SPACE HOLDER DEFINITION
C
	CALL MOVNAM(TAB5(2),EQULINE)
	VFORM=0
	IF (GETIDENT().NE..TRUE.) GOTO 900
	VFORM=1
	CALL CONCAT('V_',PREFIX,EQULINE)
	CALL MOVNAM(NAME,SAVENAME)
	CALL CONCAT(SAVENAME,EQULINE,EQULINE)
	CALL CONCAT(EQULINE,' $EQU	',EQULINE)
	CALL CONCAT(TAB5(5),EQULINE,EQULINE)
	BINVAL=BIT
	CALL MAKENUM(BINVAL)
	CALL CONCAT(NUMSTR,EQULINE,EQULINE)
900	SIZE=1
	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	IF (GETNUM(0)) SIZE=NUM
	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	MASKFORM=0
	IF (GETIDENT().NE..TRUE.) GOTO 950
	IF (IDENT('M',NAME).NE..TRUE.) GOTO 2000
	IF (VFORM.EQ.1) MASKFORM=1
950	IF (UNBLNK().NE.'>') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.'-') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.';') GOTO 2000
	LINE(LINELEN+1)=0
	IF (COL.LT.LINELEN) THEN
	   CALL CONCAT(TAB5(4),EQULINE,EQULINE)
	   CALL CONCAT(LINE(COL),EQULINE,EQULINE)
	ENDIF
	CALL PUTLINE(EQULINE,LENGTH(EQULINE))
	IF (MASKFORM.EQ.0) GOTO 960
	CALL CONCAT('M_',PREFIX,EQULINE)
	CALL CONCAT(SAVENAME,EQULINE,EQULINE)
	CALL CONCAT(EQULINE,' $EQU	',EQULINE)
	CALL CONCAT(TAB5(5),EQULINE,EQULINE)
	BINVAL=SIZE				!TO FORCE 32 BIT CALC
	BINVAL=ISHFT(1,BINVAL)
	IF (BINVAL.EQ.'80000000'X) THEN
	  BINVAL='7FFFFFFF'X			!AVOID INTEGER OVERFLOW
	 ELSE
	  BINVAL=BINVAL-1
	ENDIF
	CALL MAKENUM(ISHFT(BINVAL,BIT))
	CALL CONCAT(NUMSTR,EQULINE,EQULINE)
	CALL PUTLINE(EQULINE,LENGTH(EQULINE))
960	IF (SIZE.EQ.1) GOTO 980
	IF (VFORM.EQ.0) GOTO 980
	CALL CONCAT('S_',PREFIX,EQULINE)
	CALL CONCAT(SAVENAME,EQULINE,EQULINE)
	CALL CONCAT(EQULINE,' $EQU	',EQULINE)
	CALL CONCAT(TAB5(5),EQULINE,EQULINE)
	BINVAL=SIZE
	CALL MAKENUM(BINVAL)
	CALL CONCAT(NUMSTR,EQULINE,EQULINE)
	CALL PUTLINE(EQULINE,LENGTH(EQULINE))
980	BIT=BIT+SIZE
	GOTO 700

1500	CALL ERRORF(5,NOCLOSEANGLE)
1600	RETURN
	END

	SUBROUTINE DEFINIF
	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 GETIDENT,UNBLNK,GETNUM,IDENT,GETMARLIN

	BYTE TAB3(4),DEFSYM(133),COMMENT(133)
	DATA TAB3/9,9,9,0/

	PREFIX(1)=0
	DEFFLAG=0

90	CALL PUTLINE(LINE,LINELEN)
100	IF (GETMARLIN().EQ..FALSE.) GOTO 3000
C
C  PROCESS $DEFINI INPUT.
C
	IF (UNBLNK().EQ.';') GOTO 90
	IF (GETIDENT().EQ..FALSE.) GOTO 90
	IF (IDENT('$EQU',NAME).EQ..TRUE.) GOTO 90
	IF (IDENT('$DEF',NAME).EQ..TRUE.) GOTO 200
	IF (IDENT('$VIELD',NAME).EQ..TRUE.) GOTO 300
	IF (IDENT('_VIELD',NAME).EQ..TRUE.) GOTO 300
	IF (IDENT('$EQULST',NAME).EQ..TRUE.) GOTO 400
	IF (IDENT('$DEFEND',NAME).EQ..TRUE.) THEN
	   IF (DEFFLAG.EQ.1) THEN
	      IF (COMMENTSIZE.GT.0) THEN
	         CALL CONCAT(TAB3,DEFSYM,DEFSYM)
	         CALL CONCAT(COMMENT,DEFSYM,DEFSYM)
	      ENDIF
	      CALL PUTLINE(DEFSYM,LENGTH(DEFSYM))
	   ENDIF
	RETURN
	ENDIF
C
C CHECK FOR .=NN SYNTAX
C
	IF (IDENT('.',NAME).EQ..TRUE.) THEN
	   IF (DEFFLAG.EQ.1) THEN
	      IF (COMMENTSIZE.GT.0) THEN
	         CALL CONCAT(TAB3,DEFSYM,DEFSYM)
	         CALL CONCAT(COMMENT,DEFSYM,DEFSYM)
	      ENDIF
	      CALL PUTLINE(DEFSYM,LENGTH(DEFSYM))
	   ENDIF
	DEFFLAG=0
	GOTO 90
	ENDIF
C
C NOW FINALLY HANDLE .BLKX DIRECTIVE MERGING
C
	IF ((IDENT('.BLKL',NAME).EQ..FALSE.).AND.
	1   (IDENT('.BLKB',NAME).EQ..FALSE.).AND.
	2   (IDENT('.BLKW',NAME).EQ..FALSE.).AND.
	3   (IDENT('.BLKQ',NAME).EQ..FALSE.)) GOTO 2000
	IF (DEFFLAG.EQ.0) GOTO 90
	CALL MOVNAM(NAME,PREFIX)
	NUM=1
	IF (UNBLNK().EQ.';') GOTO 150
	IF (GETNUM(0).EQ..FALSE.) GOTO 2000
	IF (UNBLNK().NE.';') GOTO 2000
150	CALL CONCAT(9,DEFSYM,DEFSYM)
	CALL CONCAT(PREFIX,DEFSYM,DEFSYM)
	IF (NUM.NE.1) THEN
	   CALL CONCAT(9,DEFSYM,DEFSYM)
	   CALL MAKENUM(NUM)
	   CALL CONCAT(NUMSTR,DEFSYM,DEFSYM)
	ENDIF
	IF (COMMENTSIZE.NE.0) THEN
	   CALL CONCAT(9,DEFSYM,DEFSYM)
	   IF (NUM.EQ.1) CALL CONCAT(9,DEFSYM,DEFSYM)
	   CALL CONCAT(COMMENT,DEFSYM,DEFSYM)
	ENDIF
	CALL PUTLINE(DEFSYM,LENGTH(DEFSYM))
	DEFFLAG=0
	GOTO 100

200	IF (DEFFLAG.EQ.1) THEN
	   IF (COMMENTSIZE.GT.0) THEN
	      CALL CONCAT(TAB3,DEFSYM,DEFSYM)
	      CALL CONCAT(COMMENT,DEFSYM,DEFSYM)
	   ENDIF
	   CALL PUTLINE(DEFSYM,LENGTH(DEFSYM))
	ENDIF
	DEFFLAG=0
	IF (GETIDENT().EQ..FALSE.) GOTO 2000
	CALL MOVNAM(NAME,DEFSYM)
	CALL CONCAT(DEFSYM,' $DEF	',DEFSYM)
	IF (UNBLNK().NE.';') GOTO 2000
	DEFFLAG=1
	COMMENT(1)=0
	IF (COL.LT.LINELEN) THEN
	  LINE(LINELEN+1)=0
	  CALL MOVNAM(LINE(COL),COMMENT)
	ENDIF
	COMMENTSIZE=LENGTH(COMMENT)
	GOTO 100

300	CALL VIELDF
	GOTO 100

400	CONTINUE
	CALL EQULSTF
	GOTO 100
C THE FOLLOWING CODE WILL SUPPRESS EQULST PROCESSING
C	CALL PUTLINE(LINE,LINELEN)
C	IF (GETMARLIN().NE..TRUE.) GOTO 2000
C	IF (UNBLNK().EQ.'>') GOTO 90
C	GOTO 400

2000	CALL ERRORF(1,SYNTAX)
	GOTO 90
3000	CALL ERRORF(6,MISSINGE)
	RETURN
	END

	SUBROUTINE PUTLINE(STRING,LENGTH)
	BYTE STRING(*)
	J=LENGTH
	DO 100 J=J,1,-1
	IF (STRING(J).NE.' ') GOTO 200
100	CONTINUE
	WRITE(8, 98)
98	FORMAT()
	RETURN
200	WRITE(8, 99) (STRING(I),I=1,J)
99	FORMAT(<J>A1)
	END

	SUBROUTINE MAKENUM(I)
	INCLUDE 'SRC$:MDL32CMN.CMN'

	INTEGER*4 I
	BYTE STRING(12)

	IF ((I.GT.256).OR.(I.LT.0)) THEN
	   CALL MOVNAM('<^X',NUMSTR)
	   ENCODE(11,98,STRING) I
	 ELSE
	   NUMSTR(1)=0
	   ENCODE(11,99,STRING) I
	ENDIF
	STRING(12)=0
	DO 100 J=1,11
	IF (STRING(J).NE.' ') GOTO 200
100	CONTINUE
200	CALL CONCAT(STRING(J),NUMSTR,NUMSTR)

98	FORMAT(Z10,'>')
99	FORMAT(I11)

	END

	SUBROUTINE EQULSTF
C	ROUTINE TO HANDLE MDL EQULST SYNTAX

	INCLUDE 'SRC$:MDL32CMN.CMN'
	LOGICAL*1 GETIDENT,UNBLNK,GETNUM,IDENT,GETMARLIN
	BYTE TAB5(6),EQULINE(132),SAVENAME(32)
	DATA TAB5/9,9,9,9,9,0/
	DATA KNOWNVAL/0/
	INTEGER*4 STARTVAL,INCRVAL

	IF (GETIDENT().EQ..FALSE.) GOTO 2000
	CALL MOVNAM(NAME,PREFIX)
	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	IF (GETIDENT().EQ..FALSE.) GOTO 2000
	IF (IDENT(NAME,'$GBL').NE..TRUE.) GOTO 2000
	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	IF (GETNUM(0).EQ..FALSE.) THEN
	   IF (UNBLNK().EQ.','.AND.KNOWNVAL.EQ.1) GOTO 500
	   KNOWNVAL=0
	   CALL PUTLINE(LINE,LINELEN)
400	   IF (GETMARLIN().NE..TRUE.) GOTO 2000
	   CALL PUTLINE(LINE,LINELEN)
	   IF (UNBLNK().NE.'>') GOTO 400
	   RETURN
	END IF
	KNOWNVAL=1
	STARTVAL=NUM
500	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	INCRVAL=1
	IF (GETNUM(0)) INCRVAL=NUM
	IF (UNBLNK().NE.',') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.'<') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.'-') GOTO 2000
	COL=COL+1
	IF (UNBLNK().EQ.';') GOTO 750
2000	CALL ERRORF(1,SYNTAX)
700	IF (GETMARLIN().NE..TRUE.) GOTO 1500
	IF (UNBLNK().EQ.'>') GOTO 1600
	IF (UNBLNK().EQ.'-') THEN
	   COL=COL+1
	   IF (UNBLNK().NE.';') GOTO 2000
750	   IF (COL.GE.LINELEN) GOTO 700
	   LINE(LINELEN+1)=0
	   CALL CONCAT(LINE(COL),TAB5,EQULINE)
	   CALL PUTLINE(EQULINE,LENGTH(EQULINE))
	   GOTO 700
	ENDIF
	IF (UNBLNK().NE.'<') GOTO 2000
	COL=COL+1
	IF (GETIDENT().NE..TRUE.) GOTO 2000
	IF (UNBLNK().NE.',') GOTO 900
	COL=COL+1
	IF (GETNUM(1)) THEN
	  BINVAL=NUM
	  GOTO 950
	ENDIF
C
C COME HERE IF EQUATE VALUE IS NOT CALCUABLE- THIS CAN BE CAUSED BY THE USE
C OF SYMBOLS IN THE VALUE EXPRESSION OR THE USE OF CONTINUATION LINES IN THE
C VALUE EXPRESSION
C
C NOW WE CAN ATTEMPT TO FIND THE END OF THIS EXPRESSION BY PAIRING '<' AND '>'
C
	OPENCNT=0
	OUTFLG=0
800	BEGCOL=COL
	DO 850 COL=COL,132
	IF (UNBLNK().EQ.'<') THEN
	  OPENCNT=OPENCNT+1
	  GOTO 850
	ENDIF
	IF (UNBLNK().EQ.'>') THEN
	  OPENCNT=OPENCNT-1
	  IF (OPENCNT.EQ.-1) GOTO 875
	  GOTO 850
	ENDIF
	IF (UNBLNK().EQ.';') THEN
	  IF (OUTFLG.EQ.0) THEN
	    CALL CONCAT(NAME,PREFIX,EQULINE)
	    CALL CONCAT(EQULINE,' $EQU	',EQULINE)
	    CALL CONCAT(TAB5(5),EQULINE,EQULINE)
	    LINE(LINELEN+1)=0
	    CALL CONCAT(LINE(BEGCOL),EQULINE,EQULINE)
	    CALL PUTLINE(EQULINE,LENGTH(EQULINE))
	    OUTFLG=1
	  ELSE
	    CALL PUTLINE(LINE,LINELEN)
	  ENDIF
	  IF (GETMARLIN().NE..TRUE.) GOTO 1500
	  GOTO 800	
	ENDIF
850	CONTINUE
	GOTO 2000
875	ENDCOL=COL
	COL=COL+1
	IF (UNBLNK().NE.'-') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.';') GOTO 2000
	IF (OUTFLG.EQ.0) THEN
	  CALL CONCAT(NAME,PREFIX,EQULINE)
	  CALL CONCAT(EQULINE,' $EQU	',EQULINE)
	  CALL CONCAT(TAB5(5),EQULINE,EQULINE)
	ELSE
	  EQULINE(1)=0
	ENDIF
	LINE(ENDCOL)=0
	CALL CONCAT(LINE(BEGCOL),EQULINE,EQULINE)
	LINE(LINELEN+1)=0
	IF (COL.LT.LINELEN) THEN
	   CALL CONCAT(TAB5(5),EQULINE,EQULINE)
	   CALL CONCAT(LINE(COL),EQULINE,EQULINE)
	ENDIF
	CALL PUTLINE(EQULINE,LENGTH(EQULINE))
	GOTO 700

900	BINVAL=STARTVAL
	STARTVAL=STARTVAL+INCRVAL
950	IF (UNBLNK().NE.'>') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.'-') GOTO 2000
	COL=COL+1
	IF (UNBLNK().NE.';') GOTO 2000
	CALL CONCAT(NAME,PREFIX,EQULINE)
	CALL CONCAT(EQULINE,' $EQU	',EQULINE)
	CALL CONCAT(TAB5(5),EQULINE,EQULINE)
	CALL MAKENUM(BINVAL)
	CALL CONCAT(NUMSTR,EQULINE,EQULINE)
	LINE(LINELEN+1)=0
	IF (COL.LT.LINELEN) THEN
	   CALL CONCAT(TAB5(4),EQULINE,EQULINE)
	   CALL CONCAT(LINE(COL),EQULINE,EQULINE)
	ENDIF
	CALL PUTLINE(EQULINE,LENGTH(EQULINE))
	GOTO 700

1500	CALL ERRORF(5,NOCLOSEANGLE)
1600	RETURN
	END
