.TITLE	NAME$LIST	VAX NAMELIST
	.IDENT	'0.6'
 
	$DSCDEF;		DEFINE %DESCR OFFSETS
DL=DSC$W_LENGTH;	ELEMENT LENGTH
DT=DSC$B_DTYPE;		DATA TYPE
DC=DSC$B_CLASS;		CLASS CODE (ARRAY OR SCALAR)
DP=DSC$A_POINTER;	DATA ADDRESS
DD=DSC$B_DIMCT;		NUMBER OF DIMENSIONS
DZ=DSC$L_ARSIZE;	ARRAY SIZE
DA=DSC$A_A0;		BASE ADDR FOR SUBSCRIPTING
DM=DSC$L_M1;		1ST MULTIPLIER
 
	.PSECT	$LOCAL,PIC,NOEXE,LONG;	FIT WITH FORTRAN
 
ERRR:	$RAB	FAB=ERRF,-;	ERROR 'FILE' CONTROL BLOCKS
		RBF=ERM,RSZ=ERML
ERRF:	$FAB	FNM=<SYS$ERROR>,RAT=CR
 
SWITCH:	.LONG	0;	VARIOUS FLAGS & SWITCHES
SWGETV=0;	ELEMENT IS VARIABLE NAME (ALPHANUMERIC)
SWGETN=1;	ELEMENT IS VALUE
SWNINT=3;	NUMBER IS INTEGER
SWNRL=4;	NUMBER IS REAL
SWNCPX=5;	NUMBER IS COMPLEX
SWNLOG=6;	VALUE IS LOGICAL
SWNSTR=7;	VALUE IS STRING
SWDOLR=9;	$ DELIMITER
SWDCMA=10;	, DELIMITER
SWDRP=11;	) DELIMITER
SWDLP=12;	( DELIMITER
SWDEQ=13;	= DELIMITER
SWARAY=16;	VARIABLE IS ARRAY-TYPE
SWVAL=17;	VALUE FOUND
SWSUB=18;	SUBSCRIPT GIVEN
SWNEG=19;	NEG VALUE
SWERR=31;	SYS$ERROR OPEN FLAG
 
LISTSZ=80;		SIZE OF LIST OF LISTS
LIST:	.LONG	0,0;	NUMBER OF ENTRIES & 1ST 0
	.BLKL	LISTSZ+1;ENTRIES (AP OF CALL TO NAM$LIST)
LISTPT:	.BLKL	1;	CURRENT LIST PTR
 
NUMBER:	.BLKQ	1;	NUMBER SAVE PLACE
NUMBRE: .BLKQ	1;	REAL NUMBER SAVE PLACE
BASE11:	.BLKL	1;	SAVE AREA FOR (R11)
N1:	.BLKQ	1;	FOR REAL VALUE COMPUTATION
N2:	.BLKQ	1
N2A:	.BLKL	1
N3:	.BLKL	1
	.BLKB	126;	LOTS OF SPACE FOR A STRING
SUBS:	.BLKL	1;	ARRAY OFFSET VALUE
REPEAT:	.BLKL	1;	REPEAT COUNT
 
ERM:	.ASCII	':NAMELIST-E:';	ERROR MESSAGE
VARNAM:	.BLKB	15;	VARIABLE OR NAMELIST NAME
	.ASCII	':'
ERM1:	.BLKB	16;	MESSAGE OR DATA IMAGE
ERM2:	.BLKB	26;	MESSAGE
ERML1=.-ERM1
ERML2=.-ERM2
ERML=.-ERM
 
DATAL=80;		LENGTH OF DATA AREA
DDATA:	.WORD	DATAL,^X010E;DESCRIPTOR (CHARACTER)
	.LONG	DATA
	.ASCII	'           '
DATA:	.BLKB	DATAL;	DATA AREA
	.ASCII	'!!!!!!!'
DATAF:	.BYTE	^X29,4;	FORTRAN FORMAT(A)
 
WR1L=80
WR1:	.BLKB	WR1L
WR1D:	.WORD	00,256+DSC$K_DTYPE_T
	.LONG	WR1
WR2:	.ASCII	'='
WR2D:	.WORD	1,256+DSC$K_DTYPE_T
	.LONG	WR2
WR3:	.ASCII	','
WR3D:	.WORD	1,256+DSC$K_DTYPE_T
	.LONG	WR3
WR4:	.ASCII	'$END'
WR4D:	.WORD	4,256+DSC$K_DTYPE_T
	.LONG	WR4
 
	.PSECT	$PDATA,PIC,SHR,NOEXE,NOWRT
VTYPES:
	.BYTE	DSC$K_DTYPE_T;	CHARACTER (TEXT)
	.BYTE	DSC$K_DTYPE_FC;	COMPLEX
	.BYTE	DSC$K_DTYPE_WU;	LOGICAL*2
	.BYTE	DSC$K_DTYPE_BU;	LOGICAL*1
	.BYTE	DSC$K_DTYPE_LU;	LOGICAL (*4)
	.BYTE	DSC$K_DTYPE_W;	INTEGER*2
	.BYTE	DSC$K_DTYPE_L;	INTEGER (*4)
	.BYTE	DSC$K_DTYPE_D;	REAL*8
	.BYTE	DSC$K_DTYPE_F;	REAL (*4)
VTYPEN=.-VTYPES
 
WTYPES:	.LONG	FOR$IO_F_R
	.LONG	FOR$IO_D_R
	.LONG	FOR$IO_L_R
	.LONG	FOR$IO_W_R
	.LONG	FOR$IO_LU_R
	.LONG	FOR$IO_B_R
	.LONG	FOR$IO_WU_R
	.LONG	FOR$IO_FC_R
	.LONG	FOR$IO_T_DS
 
DELIMS:	.ASCII	'=(),$';	MEANINGFUL DELIMITERS
DELIML=.-DELIMS
ALPHA:	.ASCII	'ABCDEFGHIJKLMNOPQRSTUVWXYZ$_'
NUMB:	.ASCII	'0123456789-.+'
EXPDEC:	.ASCII	'ED.'
 
ERMMNY:	.ASCIC	'TOO MANY NAMELISTS'
ERMFND:	.ASCIC	'NAMELIST NOT DECLARED'
ERMDAT:	.ASCIC	'DATA RECORDS SKIPPED'
ERMNN:	.ASCIC	'INVALID VARIABLE NAME'
ERMVNF:	.ASCIC	'NAME NOT IN LIST'
ERMSYN:	.ASCIC	'SYNTAX ERROR'
ERMSUB:	.ASCIC	'INVALID SUBSCRIPT'
ERMREP:	.ASCIC	'INVALID REPEAT COUNT'
ERMV1:	.ASCIC	'BAD VARIABLE TYPE'
ERMXAL:	.ASCIC	'TOO MANY VALUES'
ERMCVT:	.ASCIC	'INVALID CONVERSION'
ERMEOD:	.ASCIC	'END OF DATA'
 
	.PSECT	$CODE,PIC,SHR,NOWRT
	.PAGE
	.SBTTL	NAM$LIST
 
;  NAMELIST / list / var-1, var-2, ... , var-i, var-j, ...
;  CALL NAM$LIST ('list','var-1',%DESCR(var-1),...,'var-i',%DESCR(var-i))
;  CALL NAM$CONT ('var-j',%DESCR(var-j),...)
 
	.ENTRY	NAM$LIST,0
	ADDL3	#2,LIST,R1;		SKIP SLOT FOR NEW LIST
LIST1:	CMPL	R1,#LISTSZ
	BLEQ	1$
	MOVAB	ERMMNY,R1;		TOO MANY ENTRIES
	MOVAL	@4(AP),R2;		PT TO DESCR('LIST-NAME')
	BRW	ERRORN;			SHOW ERROR & RETURN
1$:	MOVL	AP,LIST[R1];		ADD LIST TO LIST
	CLRL	LIST+4[R1];		FLAG END OF ENTRY
	MOVL	R1,LIST;		UPDATE COUNT
	RET;				RETURN
 
	.ENTRY	NAM$CONT,0
	ADDL3	#1,LIST,R1;		NEXT SLOT FOR CONTINUATION
	BRB	LIST1
	.PAGE
	.SBTTL	NAM$WRITE
 
;  WRITE (unit,list)
;  CALL NAM$WRITE (unit,'list')
 
	.ENTRY	NAM$WRITE,^XFFC
	BSBW	LSTFND;			FIND LIST ENTRY
	ADDL	#4,LISTPT;		BUMP FOR CONTINUATION
	MOVL	(R9)+,R8;		# ARGS (OF CALL TO NAMELIST)
	DECL	R8;			ADJUST
	MOVQ	@(R9)+,R0;		DESCR('NAMELIST')
	MOVL	@4(AP),R6;		UNIT #
	MOVW	#^A' $',WR1;		FORM 1ST RECORD:
	MOVC5	R0,(R1),#32,#15,WR1+2;	 " $NAME   "
	MOVW	#17,WR1D
	PUSHAL	DATAF;	
	PUSHL	R6;
	CALLS	#2,FOR$WRITE_SF;	WRITE(UNIT,FORMAT)
	PUSHAL	WR1D
	CALLS	#1,FOR$IO_T_DS
	CALLS	#0,FOR$IO_END
1$:	PUSHL	R6;			'OPEN'
	CALLS	#1,FOR$WRITE_SL
	PUSHL	(R9)+;			"VAR-NAME"
	CALLS	#1,FOR$IO_T_DS
	PUSHAL	WR2D;			"="
	CALLS	#1,FOR$IO_T_DS
	MOVL	(R9)+,R7;		PT TO DESCR(VAR)
	LOCC	DT(R7),#VTYPEN,VTYPES;	FIND TYPE
	BNEQ	2$;			  GOT IT
	MOVAL	@8(AP),R2;		ERROR MESSAGE & EXIT
	MOVAB	ERMV1,R1
	BRW	ERRORX
2$:	MOVL	WTYPES-4[R0],R10;	I/O ROUTINE ADDR
	MOVL	DP(R7),R11;		BASE ADDRESS
	MOVZWL	DL(R7),R4;		SIZE OF ELEMENT
	ADDL3	R11,R4,R5;		END IF NON-ARRAY
	CMPB	DC(R7),#DSC$K_CLASS_A;	WHAT CLASS?
	BNEQ	4$;			  NON-ARRAY
	ADDL3	R11,DZ(R7),R5;		END OF ARRAY
4$:	PUSHL	R11;			"VAR-VALUE"
	CMPB	DT(R7),#DSC$K_DTYPE_T;	TYPE OF VAR?
	BNEQ	46$;			  NOT CHARACTER
	MOVB	#^A"'",WR1;		MAKE UP STRING WITH 'S
	MOVL	R4,R0;			LENGTH
	MOVL	(SP)+,R1;		DATA PTR (& CLEAN STACK)
	MOVAB	WR1+1,R2;		WHERE TO COPY TO
	MOVAB	WR1+WR1L-1,R3;		MAX POSITION
	BRB	43$;			GO CHECK CHAR CT
41$:	CMPL	R2,R3;			EXCEED BUFFER?
	BGEQ	44$;			  YES
	CMPB	(R1),#^A"'";		IF ',
	BNEQ	42$
	MOVB	(R1),(R2)+;		 MAKE IT ''
42$:	MOVB	(R1)+,(R2)+;		COPY CHAR
43$:	SOBGEQ	R0,41$;			  NEXT
	CMPL	R2,R3;			END OF BUFFER?
44$:	BGTR	45$;			  NO ROOM FOR
	MOVB	#^A"'",(R2)+;		ENDING '
45$:	MOVAB	WR1,R0;			COMPUTE LENGTH
	SUBL	R0,R2
	MOVW	R2,WR1D
	PUSHAL	WR1D;			USE OUR DESCRIPTOR
46$:	CALLS	#1,(R10);		DO I/O
	ADDL	R4,R11;			NEXT ELT ADDR
	CMPL	R11,R5;			MORE?
	BGEQ	5$;			  NO
	PUSHAL	WR3D;			","
	CALLS	#1,FOR$IO_T_DS
	BRB	4$;			DO NEXT
 
5$:	SUBL	#2,R8;			MORE VARIABLES?
	BGTR	6$;			  YES
	MOVL	LISTPT,R3;		LOOK FOR CONTINUATION
	MOVL	(R3)+,R9
	BEQL	7$;			  NONE
	MOVL	R3,LISTPT;		RESET PTR FOR NEXT
	MOVL	(R9)+,R8;		# ARGS
6$:	PUSHAL	WR3D;			","
	CALLS	#1,FOR$IO_T_DS
	CALLS	#0,FOR$IO_END
	BRW	1$
 
7$:	CALLS	#0,FOR$IO_END;		TERMINATE VARIABLES
	PUSHL	R6;			" $END "
	CALLS	#1,FOR$WRITE_SL
	PUSHAL	WR4D
	CALLS	#1,FOR$IO_T_DS
	CALLS	#0,FOR$IO_END
	RET;				RETURN
	.PAGE
	.SBTTL	NAM$READ
 
;  READ (unit,list [,END=endst,ERR=errst] )
;  CALL NAM$READ (unit,'list' [,*endst,*errst] )
 
;  setup and find data with proper listname
 
	.ENTRY	NAM$READ,^XFFC
	BSBW	LSTFND;			FIND LIST ENTRY
	CLRL	R8;			COUNT DATA RECORDS SKIPPED
2$:	BSBW	READ;			READ DATA
	CMPB	(R11),#^A'$';		$ IN COL 2?
	BEQL	4$;			  YES
	CMPB	(R11),#^A'&';		HOW ABOUT &?
	BEQL	4$;			  THAT'L DO
	CMPB	(R11),#^A'!';		IF !,
	BEQL	2$;			  IGNORE ENTIRE LINE
3$:	INCL	R8;			BUMP COUNT
	BRB	2$;			  TRY AGAIN
4$:	MOVQ	@4(R9),R4;		LISTNAME DESCR
	CMPC3	R4,(R5),1(R11);		COMPARE NAMES
	BNEQ	3$;			  WRONG NAME
	CVTWL	R4,R4;			# OF CHARS
	MOVAB	1(R11)[R4],R11;		 SKIP NAME
	CMPB	(R11),#^A' ';		IF NOT BLANK,
	BEQL	5$
	CMPB	(R11),#9;		 OR TAB,
	BNEQ	3$;			  WRONG NAME
5$:	TSTL	R8;			ANY DATA SKIPPED?
	BEQL	GTNAME;			  NO
	MOVC5	R4,(R5),#^A' ',#15,VARNAM;SET LIST NAME
	MOVB	#^A'W',ERM+10;		WARNING
	MOVAB	ERMDAT,R1;		TELL IT
	BSBW	ERROR
	MOVB	#^A'E',ERM+10;		ERROR
 
;	  get a variable name
 
GTNAME:	BSBW	GET;			GET NAME
	BBS	#SWGETV,SWITCH,SRCHV;	  GOT ONE (MAYBE)
	MOVAB	ERMNN,R1;		NO NAME
	BRW	ERRORZ;			TELL & EXIT
 
;	  look for variable name in current list
 
SRCHV:	PUSHL	R11;			SAVE R11
	MOVL	LISTPT,R11;		1ST ENTRY IN LIST-LIST
	MOVL	(R11)+,R9;		PT TO USER LIST
	MOVL	(R9)+,R8;		# ARGS
	DECL	R8;			SKIP NAMELIST ARG
	BLEQ	2$;			  NO OTHER ARGS
	TSTL	(R9)+
1$:	MOVQ	(R9)+,R6;		DESCR(NAME)/DESCR(VAR) PTRS
	MOVQ	(R6),R4;		DESCR(NAME)
	CMPC5	R4,(R5),#0,R10,VARNAM
	BEQL	4$;			  GOT IT
	SUBL	#2,R8;			DECR ARG CT
	BGTR	1$;			  TRY AGAIN
2$:	MOVL	(R11)+,R9;		TRY CONTINUATION
	BEQL	3$;			  NONE
	MOVL	(R9)+,R8;		# ARGS
	BRB	1$;			GO CONTINUE SEARCH
3$:	MOVL	(SP)+,R11;		RESTORE R11
	MOVAB	ERMVNF,R1;		TELL NOT FOUND
	BRW	ERRORX;			& EXIT (TEMP?)
;  setup to process variable
4$:	MOVL	(SP)+,R11;		RESTORE R11
	CLRB	SWITCH+2;		CLEAR VARIABLE FLAGS
	CMPB	DC(R7),#DSC$K_CLASS_A;	DESCRIPTOR CLASS?
	BNEQ	5$;			  NON-ARRAY (ASSUME SCALAR)
	CLRL	SUBS;			CLEAR 'SUBSCRIPT'
	BBCS	#SWARAY,SWITCH,5$;	FLAG ARRAY-TYPE
5$:	BBS	#SWDLP,SWITCH,10$;	  SUBSCRIPT GIVEN
	BBS	#SWDEQ,SWITCH,99$;	  NO SUBSCRIPT
	BRW	17$
99$:	BRW	NOSUB
;  process a subscript
10$:	BBC	#SWARAY,SWITCH,14$;	  SUB ON NON-ARRAY
	MOVZBL	DD(R7),R5;		# OF DIMENSIONS
	MOVAL	DM(R7),R4;		PT TO 1ST DIM
	MOVAL	(R4)[R5],R8;		PT TO BOUNDS
11$:	BSBW	GET;			GET SUBSCRIPT
	BBC	#SWGETN,SWITCH,14$;	  NOT NUMBER
	MOVL	NUMBER,R2;		LOAD REGISTER WITH VALUE
	CMPL	R2,(R8)+;		CK LOWER BOUND
	BLSS	14$
	CMPL	R2,(R8)+;		CK UPPER BOUND
	BGTR	14$
;					COMPUTE SUBSCRIPT OFFSET
	MOVAL	DM(R7),R1;		1ST DIM
	MOVL	R4,R6;			CURRENT DIM
12$:	SUBL	#4,R6;			PREVIOUS DIM
	CMPL	R6,R1;			PASSED 1ST?
	BLSS	13$;			  YES, THROUGH
	MULL	(R6),R2;		* PREV DIM
	BRB	12$;			DO NEXT
13$:	ADDL	R2,SUBS
	BBC	#SWDCMA,SWITCH,15$;	  NO COMMA, MUST BE THRU
	ADDL	#4,R4;			ADJUST DIM PTR
	SOBGTR	R5,11$;			  MORE TO GO
14$:	MOVAB	ERMSUB,R1;		BAD SUBSCRIPT
	BRW	ERRORZ
15$:	DECL	R5
	BNEQ	14$;			  NOT ENOUGHT SUBSCRIPTS
	BBC	#SWDRP,SWITCH,14$;	LAST SUB NOT END WITH )
	BBCS	#SWSUB,SWITCH,16$;	INDICATE SUBSCRIPT USED
16$:	BSBW	GET;			GET =
	BBS	#SWGETN,SWITCH,17$;	  NUMBER FOUND
	BBS	#SWGETV,SWITCH,17$;	  NAME FOUND
	BBS	#SWDEQ,SWITCH,NOSUB;	  GOT =
17$:	BRW	SYNERR;			SYNTAX ERROR
;  find value(s)
NOSUB:
	CLRL	REPEAT;			NO REPEATS
1$:	BSBW	GET;			GET VALUE
	BBC	#SWGETV,SWITCH,2$
	BRW	NOVAL;			  NAME FOUND
2$:	BBS	#SWGETN,SWITCH,3$
	BRW	SYNERR;			  NO NUMBER
3$:	CMPB	(R11),#^A'*';		REPEAT COUNT GIVEN?
	BNEQ	VALUE;			  NO
	INCL	R11;			SKIP *
	BBC	#SWARAY,SWITCH,4$;	  MULT VAL TO SINGLE VAR
	BBC	#SWNINT,SWITCH,4$;	  REPEAT CT NOT INTEGER
	TSTL	REPEAT
	BNEQ	4$;			  MULTIPLE REAPEAT CT
	MOVL	NUMBER,R2;		STORE THE COUNT IN REGISTER
	MOVL	R2,REPEAT;		SAVE REPEAT CT
	BGTR	1$;			GO GET DATA VALUE
4$:	MOVAB	ERMREP,R1;		BAD REPEAT COUNT
	BRW	ERRORZ
;  compare variable type & data type; convert if appropriate
VALUE:	BBC	#SWNSTR,SWITCH,1$
	BRW	STORE;			STRING VAR, NO CONVERSION
1$:	LOCC	DT(R7),#VTYPEN,VTYPES;	FIND VARIABLE TYPE
	CASEL	R0,#1,#VTYPEN-1;	BRANCH BASED ON TYPE
	.WORD	10$-.;			  REAL
	.WORD	12$-.+2;		  REAL*8
	.WORD	13$-.+4;		  INTEGER
	.WORD	13$-.+6;		  INTEGER*2
	.WORD	14$-.+8;		  LOGICAL (*4)
	.WORD	14$-.+10;		  LOGICAL*1
	.WORD	14$-.+12;		  LOGICAL*2
	.WORD	15$-.+14;		  COMPLEX
	.WORD	16$-.+16;		  CHARACTER
	MOVAB	ERMV1,R1;		BAD VARIABLE TYPE
	BRW	ERRORX
10$:	BBC	#SWNRL,SWITCH,11$;	  NOT REAL DATA
	CVTDF	NUMBRE,NUMBER;		ROUND TO SINGLE PREC.
	BRW	STORE
11$:	BBC	#SWNINT,SWITCH,19$;	  NOT INT, CANT CVT
	CVTLF	NUMBER,NUMBER;		CVT INT TO SINGLE
	BRB	STORE
12$:	BBC	#SWNRL,SWITCH,18$;	  ALREADY REAL, NO CONVERSION
	MOVD	NUMBRE,NUMBER;
	BRB	STORE;
18$:	BBC	#SWNINT,SWITCH,19$;	  NOT INT, CANT CVT
	CVTLD	NUMBER,NUMBER;		CVT INT TO REAL
	BRB	STORE
13$:	BBS	#SWNINT,SWITCH,STORE;	  ALREADY INT, NO CVT
	BBC	#SWNRL,SWITCH,19$;	BAD IF NOT REAL
	CVTDL	NUMBRE,NUMBER;		CONVERT TO INTEGER
	BRB	STORE;			TAKE CARE OF CONVERTED VALUE
14$:	BBS	#SWNLOG,SWITCH,STORE;	  ALREADY LOGICAL
	BBS	#SWNINT,SWITCH,STORE;	  INT, LEAVE IT
	BRB	19$;			ALL ELSE BAD
15$:	BBS	#SWNCPX,SWITCH,STORE;	  ALREADY COMPLEX
	BRB	19$
16$:	BBS	#SWNSTR,SWITCH,STORE;	  STRING TO STRING IS OK
19$:	MOVAB	ERMCVT,R1;		INVALID TYPE FOR CONVERSION
	BRW	ERRORZ
 
STORE:	BBCS	#SWVAL,SWITCH,21$;	SOME VALUE SET
;  find where to store
21$:	MOVL	DP(R7),R6;		BASE ADDR
	MOVZWL	DL(R7),R10;		ELEMENT LENGTH
	ADDL3	R6,R10,R8;		END OF AREA (IF NON-ARRAY)
	BBC	#SWARAY,SWITCH,24$;	  NOT ARRAY
	ADDL3	R6,DZ(R7),R8;		END OF AREA (ARRAY)
	BBC	#SWSUB,SWITCH,22$;	  NO SUBSCRIPT GIVEN
	MOVL	DA(R7),R6;		BASE FOR SUBSCRIPTING
22$:	MULL3	SUBS,R10,R0;		OFFSET FOR SUBSCRIPT
	ADDL	R0,R6;			+ BASE
23$:	CMPL	R6,R8;			STOR LOC EXCEED LIMIT?
	BLSS	24$;			  NO, OK
	MOVAB	ERMXAL,R1;		DATA EXCEEDS ARRAY
	BRW	ERRORZ
;  store proper length element
24$:	BBS	#SWNSTR,SWITCH,40$;	  STRING
	CMPW	R10,#4
	BGTR	27$
	BEQL	26$
	CMPW	R10,#2
	BEQL	25$
	MOVB	NUMBER,(R6);		1-BYTE
	BRB	28$
25$:	MOVW	NUMBER,(R6);		2-BYTE
	BRB	28$
26$:	MOVL	NUMBER,(R6);		4-BYTE
	BRB	28$
27$:	MOVQ	NUMBER,(R6);		8-BYTE
	BRB	28$
40$:	CMPB	DT(R7),#DSC$K_DTYPE_T;	STRING VAR?
	BEQL	41$;			  YES, USE ITS OWN LENGTH
	MOVL	NUMBER,R10;		LENGTH OF STRING GIVEN
	ADDL3	R10,R6,R0;		CHECK FOR OVERFLOW
	CMPL	R0,R8
	BLEQ	41$
	SUBL3	R6,R8,R10;		TRUNCATE TO FIT
41$:	MOVC5	NUMBER,NUMBER+4,#^A' ',R10,(R6);MOVE STRING
28$:	ADDL	R10,R6;			INCR LOC FOR NEXT ELT
	INCL	SUBS;			BUMP SUB VALUE
	DECL	REPEAT;			REPEATED VALUE?
	BGTR	23$;			  YES, STORE SAME VAL
 
	BBS	#SWDCMA,SWITCH,30$;	  VAL END WITH ,
	BBC	#SWDOLR,SWITCH,31$;	  UNKNOWN DELIMITER
	CLRL	R0;			SUCCESSFUL COMPLETION
	RET;		$ FOUND, END OF DATA,   A L L   D O N E !
30$:	BBC	#SWARAY,SWITCH,31$;	  NO ARRAY
	BRW	NOSUB;			TRY FOR NEXT VALUE
31$:	BRW	GTNAME;			TRY FOR NEXT VAR NAME
;  syntax error
SYNERR:	MOVAB	ERMSYN,R1;		SYNTAX ERROR
	BRW	ERRORZ
;  no numeric value; might be T or F or next variable name
NOVAL:	BBS	#SWDLP,SWITCH,1$
	BBC	#SWDEQ,SWITCH,2$
1$:	BBC	#SWVAL,SWITCH,SYNERR
	BRW	SRCHV;			LOOKS LIKE NEXT VAR
2$:	BBS	#SWDCMA,SWITCH,3$;	  MAYBE T OR F
	BBC	#SWDOLR,SWITCH,SYNERR;	  NO VALUE
3$:	CMPL	#1,R10;			1-CHAR 'NAME'?
	BNEQ	SYNERR;			  NO, CAN'T BE T OR F
	CLRL	NUMBER;			ASSUME FALSE
	BBCS	#SWNLOG,SWITCH,4$;	SET TYPE LOGICAL
4$:	CMPB	VARNAM,#^A'F'
	BEQL	5$;			  VALUE IS 'F'
	CMPB	VARNAM,#^A'T'
	BNEQ	SYNERR
	INCL	NUMBER;			VALUE IS 'T'
5$:	BRW	VALUE;			GO PROCESS LOGICAL VALUE
	.PAGE
	.SBTTL	NAM$READ - GET ELEMENT ROUTINE
 
;  preliminary examination
 
GET:	BSBW	SKIPB;			SKIP BLANKS
	CLRW	SWITCH;			CLEAR 'GET' FLAGS
	LOCC	(R11),#13,NUMB
	BNEQ	GETNUM;			  0-9, +, -, OR .
	LOCC	(R11),#26,ALPHA
	BNEQ	GETVAR;			  ALPHA, MUST BE VAR NAME
	CMPB	(R11),#^A'('
	BNEQ	1$
	BRW	GETCPX;			  (, MUST BE COMPLEX
1$:	CMPB	(R11),#^A"'"
	BNEQ	GETDEL
	BRW	GETSTR;			  ', MUST BE STRING
;  set delimiter switch
GETDEL:	BSBW	SKIPB;			SKIP BLANKS FIRST
	LOCC	(R11),#DELIML,DELIMS;	WHAT KIND OF DELIMITER?
	BNEQ	2$;			  SOMETHING RECOGNIZABLE
	CMPB	(R11),#^A'&'
	BNEQ	1$;			  OH, WELL...
	MOVL	#SWDOLR-8,R0;		FAKE $
2$:	INCL	R11;			BUMP PAST DELIM
	BBCS	R0,SWITCH+1,1$;		SET APPROPRIATE SWITCH
1$:	RSB;				RETURN
;  integer or real
GETNUM:	MOVL	R11,BASE11;		SAVE FOR REAL NUMBER LATER
	BSBW	GETINT;			GET AN INTEGER
	LOCC	(R11),#3,EXPDEC;	DECIMAL OR EXPONENT?
	BNEQ	2$;			  YES, MUST BE REAL #
1$:	MOVL	R2,NUMBER;		SAVE THE VALUE
	BBCS	#SWNINT,SWITCH,2$;	 FLAG INTEGER, GET DELIMITER
2$:	MOVL	BASE11,R11;		STORE BASE BACK IN R11 FOR REAL
	BSBW	GETRL;			GET REAL VALUE
	MOVD	R2,NUMBRE;		SAVE IT
	BBCS	#SWNRL,SWITCH,GOTNUM;	 & FLAG IT
GOTNUM:	BBCS	#SWGETN,SWITCH,GETDEL;	FLAG NUMBER, GET DELIM
 
;  parse the variable name (alpha-numeric + $ + _)
GETVAR:	MOVAB	VARNAM,R10;		PT TO PLACE TO KEEP NAME
	MOVC5	#0,(R0),#32,#15,(R10);	BLANK OUT NAME
	MOVL	#15,R3;			MAX CHAR CT
1$:	MOVB	(R11)+,(R10)+;		COPY CHAR
	LOCC	(R11),#38,ALPHA;	TEST NEXT
	BEQL	2$;			  NOT ALPHA, NUMB, $, _
	SOBGTR	R3,1$
2$:	SUBL3	R3,#16,R10;		# CHARS IN NAME
	BBCS	#SWGETV,SWITCH,3$;	 SET VAR-FOUND FLAG, CK DELIM
3$:	BRW	GETDEL
 
;  process complex value
GETCPX:	INCL	R11;			SKIP (
	BSBW	GETRL;			GET A REAL VALUE
	CVTDF	R2,NUMBER;		SAVE REAL PART
	CLRD	R0;			CLEAR IMAGINARY
	CMPB	(R11),#^A',';		COMMA?
	BNEQ	1$;			  NO
	INCL	R11;			SKIP COMMA
	BSBW	GETRL;			GET IMAGINARY
1$:	CVTDF	R2,NUMBER+4;		SAVE IT
	CMPB	(R11),#^A')';		IF NOT ),
	BEQL	2$
	BRW	GETDEL;			  SOMETHING WRONG
2$:	INCL	R11;			SKIP )
	BBCS	#SWNCPX,SWITCH,GOTNUM;	 GO FLAG DELIMITER
 
;  process a string
GETSTR:	INCL	R11;			SKIP '
	MOVAB	NUMBER+4,R1;		PLACE TO PUT STRING
	MOVL	R1,R2;			SAVE FOR LENGTH CALC
	MOVAB	DATA+DATAL,R3;		LOC OF END OF DATA
1$:	CMPB	(R11),#^A"'";		CHECK FOR ENDING '
	BNEQ	2$
	INCL	R11;			SKIP '
	CMPB	(R11),#^A"'";		2 IN A ROW?
	BNEQ	3$;			  NO, TRUE END
2$:	CMPL	R11,R3;			END OF DATA?
	BGEQ	3$;			  YES, MISSING END '
	MOVB	(R11)+,(R1)+;		COPY CHARACTER
	BRB	1$;			GO FOR NEXT
3$:	SUBL3	R2,R1,NUMBER;		SET STRING LENGTH
	BBCS	#SWNSTR,SWITCH,4$;	GO SET FLAGS
4$:	BRW	GOTNUM
 
;    routines
 
;  get (signed) integer value
GETINT:	BBCC	#SWNEG,SWITCH,1$;	CLEAR NEG SWITCH
1$:	CMPB	(R11),#^A'-';		TEST FOR NEGATIVE NUMBER
	BNEQ	2$;			  NO
	INCL	R11;			SKIP -
	BBCS	#SWNEG,SWITCH,GETUNT;	FLAG IT, GET VALUE
2$:	CMPB	(R11),#^A'+';		CHECK FOR UNARY +
	BNEQ	GETUNT;			  NO
	INCL	R11;			SKIP +
;  get unsigned integer
GETUNT:	CLRQ	R2;			INIT VALUE & CLEAR DIGIT
2$:	LOCC	(R11),#10,NUMB;		CHECK CHARACTER
	BEQL	3$;			  NOT DIGIT
	SUBB3	#^A'0',(R11)+,R3;	CHANGE DIGIT TO INTEGER
	MULL	#10,R2;			N*10
	ADDL	R3,R2;			+DIGIT
	BRB	2$;			GO TO NEXT
3$:	BBC	#SWNEG,SWITCH,4$;	TEST FOR NEG
	MNEGL	R2,R2;			NEGATE NUMBER
4$:	RSB
 
;  get integer into double word
GETINTR:	BBCC	#SWNEG,SWITCH,1$;	CLEAR NEG SWITCH
1$:	CMPB	(R11),#^A'-';		TEST FOR NEGATIVE NUMBER
	BNEQ	2$;			  NO
	INCL	R11;			SKIP -
	BBCS	#SWNEG,SWITCH,GETUNTR;	FLAG IT, GET VALUE
2$:	CMPB	(R11),#^A'+';		CHECK FOR UNARY +
	BNEQ	GETUNTR;			  NO
	INCL	R11;			SKIP +
;  get unsigned integer
GETUNTR:	CLRQ	R2;			INIT VALUE & CLEAR DIGIT
2$:	LOCC	(R11),#10,NUMB;		CHECK CHARACTER
	BEQL	3$;			  NOT DIGIT
	CLRQ	R0;
	SUBB3	#^A'0',(R11)+,R0;	CHANGE DIGIT TO INTEGER
	MULD	#10.0,R2;		N*10
	CVTLD	R0,R0;			CONVERT DIGIT TO DOUBLE
	ADDD2	R0,R2;			+DIGIT
	BRB	2$;			GO TO NEXT
3$:	BBC	#SWNEG,SWITCH,4$;	TEST FOR NEG
	MNEGD	R2,R2;			NEGATE NUMBER
4$:	RSB
;  get real value
GETRL:	BSBW	GETINTR;			GET INTEGER
	MOVQ	R2,N1;			SAVE INTEGER
	CLRQ	N2;			CLEAR FRACTION
	CMPB	(R11),#^A'.';		DECIMAL PT?
	BNEQ	1$;			  NO
	INCL	R11;			BUMP PTR
	MOVL	R11,N2A;		SET TO COUNT CHARS IN FRAC
	BSBW	GETUNTR;			GET FRACTION
	MOVQ	R2,N2;			SAVE FRACTION
	SUBL3	N2A,R11,N2A;		# OF DIGITS IN FRAC
1$:	CLRL	N3;			CLEAR EXPONENT
	LOCC	(R11),#2,EXPDEC;	EXPONENT GIVEN?
	BEQL	5$;			  NO
	INCL	R11;			BUMP PTR
	BSBW	GETINT;			GET EXPONENT VALUE
	MOVL	R2,N3;			SAVE EXPONENT
5$:	MOVD	N1,R2;
	MOVD	N2,R0;
	TSTD	R0;			TEST FOR ZERO FRACTION;
	BEQL	7$;			  ZERO
6$:	DIVD	#10.0,R0;		ADJUST FRACTION
	SOBGTR	N2A,6$;			  FOR EACH DIGIT
	ADDD	R0,R2;			INTEGER + FRACTION
7$:	TSTL	N3;			ANY EXPONENT?
	BEQL	10$;			  NO
	BGTR	9$;			  POSITIVE
8$:	DIVD	#10.0,R2;		ADJUST FOR NEGATIVE EXP
	AOBLSS	#0,N3,8$
	RSB
9$:	MULD	#10.0,R2;		ADJUST FOR POSITIVE EXP
	SOBGTR	N3,9$
10$:	RSB;				RETURN
 
;  READ - Read a data record
READ:	PUSHAL	1$;			END= ADDRESS
	CLRL	-(SP);			NO ERR=
	PUSHAL	DATAF;			FORMAT
	PUSHL	@4(AP);			UNIT
	CALLS	#4,FOR$READ_SF;		SETUP FORTRAN READ
	PUSHAL	DDATA;			DATA DESCRIPTOR
	CALLS	#1,FOR$IO_T_DS;		READ IT
	CALLS	#0,FOR$IO_END;		'CLOSE' IT
	MOVAL	DATA+1,R11;		PT TO COL 2
	RSB;				RETURN
1$:	MOVAB	@8(AP),R1;		SET LIST NAME
	MOVC5	(R1),@4(R1),#32,#15,VARNAM
	MOVAB	ERMEOD,R1;		SHOW EOD MESSAGE
	BSBW	ERROR
	MOVL	#1,R0;			END OF DATA RETURN
	RET
 
;  SKIPB - Skip blanks in the data record
SKIPT:	INCL	R11;			SKIP TAB
SKIPB:	SKPC	#^A' ',#DATAL,(R11);	SKIP
	MOVL	R1,R11;			NEW PTR
	CMPB	(R1),#^A'!';		END OF DATA?
	BEQL	1$;			  YES
	CMPB	(R1),#9;		TAB?
	BEQL	SKIPT;			  YES, TREAT AS BLANK
	RSB;				RETURN
1$:	BSBW	READ;			GET NEXT RECORD
	BRB	SKIPB;			LOOK AGAIN
	.PAGE
	.SBTTL	MISCELLANEOUS ROUTINES
 
;  LSTFND - Find list-of-lists element corresponding to namelist name
;  given in current NAM$READ or NAM$WRITE call.
LSTFND:	MOVL	LIST,R8;		NUMBER OF ENTRIES
	BEQL	3$;			  TSK, TSK
1$:	TSTL	LIST-4[R8];		FIND INITIAL ENTRY
	BEQL	2$;			  FOUND
	SOBGTR	R8,1$
	BRB	3$;			MUST BE NAM$LIST/NAM$CONT ERROR
2$:	MOVL	LIST[R8],R9;		PT TO NAM$LIST ARG LIST
	CMPL	4(R9),8(AP);		SAME DESCRIPTOR?
	BEQL	4$;			  YES
	SUBL	#2,R8;			TRY NEXT IF ANY
	BGTR	1$
3$:	MOVAB	ERMFND,R1;		NOT FOUND, MESSAGE & EXIT
	MOVAB	@8(AP),R2;		PT TO NAME DESCR
	BRB	ERRORN
4$:	MOVAL	LIST[R8],LISTPT;	SAVE PTR
	RSB;				RETURN
 
;  ERRORN - Change variable name (if any) to list name; print msg; exit
ERRORN:	PUSHL	R1
	MOVC5	(R2),@4(R2),#^A' ',#15,VARNAM;SET LIST NAME
	MOVL	(SP)+,R1
;  ERRORX - Print error message and exit
ERRORX:	BSB	ERROR;			PRINT ERROR MESSAGE
ERRORY:	MOVL	#2,R0;			ERROR STATUS
	RET;				RETURN TO USER PROGRAM
;  ERRORZ - Insert data image near error; print msg; exit
ERRORZ:	MOVZBL	(R1)+,R0;		MSG LENGTH
	MOVC5	R0,(R1),#32,#ERML2,ERM2;COPY MSG
	MOVC3	#15,-10(R11),ERM1;	INSERT DATA IMAGE
	MOVB	#^A':',ERM2-1
	BSB	ERR1;			SEND IT
	BRB	ERRORY
 
;  ERROR - Print error message and return
ERROR:	MOVZBL	(R1)+,R0;		MSG LENGTH
	MOVC5	R0,(R1),#32,#ERML1,ERM1;COPY MSG
ERR1:	BBSS	#SWERR,SWITCH,ERRPUT;	 SKIP IF OPEN
	$CREATE	FAB=ERRF
	$CONNECT RAB=ERRR
ERRPUT:	$PUT	RAB=ERRR;		PUT OUT MESSAGE
	RSB;				RETURN
 
	.END