;;
;	LOGICAL FUNCTION ARG_EXIST( n )
;
;
;	Returns, as the function result, an indication of whether the  Nth
;	argument passed to the routine which called ARG_EXIST actually ex-
;	ists.   The Nth argument will not exist if N > the total number of
;	arguments passed or if the Nth argument was  omitted  [as  is  the
;	second  argument  in  'CALL X(A,,B)' ].   'N' is an integer in the
;	range (1,255).
;
;	NOTE--Character string arguments  to  FORTRAN  subprograms  cannot
;	      ever  be  omitted unless the corresponding dummy argument is
;	      either non-existent or not of  character  data  type.   This
;	      means  that  such  arguments can only be 'passed through' to
;	      another subprogram, as described  in  routine  'ARG_ADDRESS'
;	      below.
;
;	.INDEX ARGUMENTS>>
;
;	Alan L. Zirkle     Naval Surface Weapons Center
;			   Code K53
;	28 Jun 1982	   Dahlgren, Virginia  22448
;

	.ENTRY	ARG_EXIST, ^M<>

	MOVZBL	@4(AP),R0	; VALUE OF N IS NOW IN R0

	BEQL	FALSE		; ZERO IS NOT LEGAL VALUE FOR N

	CMPB	R0,@8(FP)	; 8(FP) IS CALLER'S AP

	BGTRU	FALSE		; BRANCH IF N > TOTAL NUMBER OF ACTUAL ARGS

	TSTL	@8(FP)[R0]	; TEST Nth ACTUAL ARGUMENT ADDRESS--IT WILL
				;  BE ZERO IF THE ARGUMENT DOESN'T EXIST
	BEQL	FALSE

	MOVL	#1,R0		; THE ARGUMENT DOES EXIST--RETURN .TRUE.

	RET

FALSE:	CLRL	R0		; THE ARGUMENT DOESN'T EXIST--RETURN .FALSE.

	RET

	.TITLE	AZ_IO

;;
;	Routines AZ_OPEN, AZ_READ, and AZ_CLOSE
;
;
;	These  are simple, no-frill routines to read a card-image file us-
;	ing RMS.
;
;		status = AZ_OPEN('file_name')
;
;		status = AZ_READ()
;
;		CALL AZ_CLOSE
;
;	Only one file may be open at at time using these routines.
;
;	Each call to AZ_READ reads one record (80 characters max) into the
;	string RECORD, defined as:
;
;		CHARACTER*80 RECORD
;		COMMON /READ_/ RECORD
;
;	If the record is longer than 80 characters, it is truncated  with-
;	out notification; if it is shorter than 80 characters, the remain-
;	der  of RECORD has unpredictable contents.   When  end-of-file  is
;	encountered,  the file is closed and a status value of zero is re-
;	turned.
;
;	.INDEX DISK I/O>>
;
;	Alan L. Zirkle     Naval Surface Weapons Center
;			   Code K53
;	15 Jan 1983	   Dahlgren, Virginia  22448
;

	.PSECT	$LOCAL, LONG,PIC,NOSHR,NOEXE,RD,WRT


INFAB:	$FAB	FAC=GET,FOP=SQO

INRAB:	$RAB	FAB=INFAB,ROP=RAH,UBF=RECORD,USZ=80


	.PSECT	$CODE, LONG,PIC,SHR,EXE,RD,NOWRT


	.ENTRY	AZ_OPEN, ^M<>

	MOVL	@4(AP), R0

	MOVB	R0, INFAB+FAB$B_FNS

	MOVL	4(AP), R0

	MOVL	4(R0), INFAB+FAB$L_FNA

	$OPEN	FAB=INFAB

	BLBC	R0, EXIT

	$CONNECT RAB=INRAB

EXIT:	RET

	.ENTRY	AZ_READ, ^M<>

	$GET	RAB=INRAB

	BLBS	R0, RETURN

	CMPL	R0, #RMS$_RTB

	BNEQ	QUIT		; QUIT UNLESS 'RECORD TOO LARGE'

	INCL	R0

RETURN:	RET

	.ENTRY	AZ_CLOSE, ^M<>

QUIT:	$CLOSE	FAB=INFAB

	CLRL	R0

	RET	


	.PSECT	READ_,PIC,OVR,GBL,SHR,NOEXE,LONG


RECORD:	.BLKB	80

;	.END

	.TITLE	ITEM_LIST

;;
;	SUBROUTINE ITEM_LIST( array , code1 , buf1 [, rlen1] , ... ,
;
;+						   coden , bufn [, rlenn])
;
;
;	Builds a list of 'item descriptors' as required by several VAX/VMS
;	System Services as their 'ITMLST' argument.   The list is built in
;	the ARRAY argument,  which must be an INTEGER*4 array large enough
;	to hold the list (three elements for each item code, plus one ele-
;	ment as a terminator).
;
;	The CODEi arguments are the item codes for the items to be return-
;	ed by the System Service. For each item code, a BUFi argument must
;	be supplied.  If the corresponding item code will cause an address
;	or a 'value' (integer)  to be returned,  BUFi must be an INTEGER*4
;	variable and the corresponding RLENi  argument must not be present
;	(not even as  a null argument).   If the item code  will  return a
;	'string', BUFi must be a CHARACTER variable, and RLENi must either
;	be a null argument or an INTEGER*4 variable.  If present, the act-
;	ual length of the string will be returned in RLENi.  For example:
;
;	  CALL ITEM_LIST(ITMLST,JPI$_PRI,PRIORITY,JPI$_USERNAME,USERN,,
;	1					   JPI$_PRCNAM,PRCNAM,LEN)
;
;	The JPI$_PRI item code returns an integer value,  so PRIORITY must
;	be an INTEGER*4 variable.   JPI$_USERNAME and JPI$_PRCNAM both re-
;	turn strings, so USERN and PRCNAM must be CHARACTER variables, and
;	the RLENi arguments must be used  (a null argument is used for the
;	USERNAME item and INTEGER*4 variable LEN for the PRCNAM item).
;
;	ITEM_LIST will signal  SS$_INSFARG  if it determines that you have
;	not passed a correct argument list.   It cannot,  however, do this
;	in all cases,  so a bad argument list may not  be discovered until
;	you call the System Service and get an abort or incorrect results.
;	
;	ITEM_LIST will not work correctly if any of the BUFi arguments are
;	integers which, at the time ITEM_LIST is called, contain  hex val-
;	ues '010Ennnn' (where n is any digit).
;
;	.INDEX ARGUMENTS>>
;
;	Alan L. Zirkle     Naval Surface Weapons Center
;			   Code K53
;	14 May 1985	   Dahlgren, Virginia  22448
;

	$SSDEF

	.PSECT	$CODE, LONG,PIC,SHR,EXE,RD,NOWRT

	.ENTRY	ITEM_LIST, ^M<R2,R3,R4>

	MOVZBL	(AP), R0	; R0 = Count of arguments
	DECL	R0		; R0 = Count of arguments, minus one
	MOVAL	8(AP), R1	; R1 = Address of second argument's address
	MOVL	4(AP), R4	; R4 = Address of array to be filled

LOOP:
	SUBL	#2, R0		; Decrement argument count by 2
	BLSS	ERROR		; Branch if argument(s) missing
	MOVAW	@(R1)+, R3	; Get address of item code
	BEQL	ERROR		; Branch if argument is null
	MOVW	(R3), R3	; Get item code
	MOVAL	@(R1)+, R2	; R2 = Address of buffer (or buffer descriptor)
	BEQL	ERROR		; Branch if argument is null
	CMPW	2(R2), #^X010E	; Is this a string descriptor?
	BEQL	DESCR		; Branch if it is
	MOVW	#4, (R4)+	; Store length of 4
	MOVW	R3, (R4)+	; Store item code
	MOVL	R2, (R4)+	; Store longword's address
	CLRL	(R4)+		; Store null length return value address
	BRB	LOOPEND

DESCR:
	DECL	R0		; Decrement argument count by another 1
	BLSS	ERROR		; Branch if RLENi argument missing
	MOVW	0(R2), (R4)+	; Store length of string
	MOVW	R3, (R4)+	; Store item code
	MOVL	4(R2), (R4)+	; Store string's address
	MOVAL	@(R1)+, (R4)+	; Store return value address (may be null)

LOOPEND:
	TSTL	R0		; Are all arguments processed?
	BGTR	LOOP		; Loop if not
	CLRL	(R4)		; Insert zero item code as a terminator
	RET			; Return

ERROR:
	PUSHL	#SS$_INSFARG	; Signal SS$_INSFARG if the argument list
	CALLS	#1, G^LIB$SIGNAL ; is not correct.

;	.END

;;
;	INTEGER*4 FUNCTION LBYTE( integer )
;
;
;	Extracts the low-order byte  from the INTEGER*4 or INTEGER*2 argu-
;	ment INTEGER,  and sign extends the value.   This allows the value
;	to be assigned to a BYTE variable  without danger of integer over-
;	flow.  Examples:
;
;	  Incorrect:  INTEGER*4 I	Correct:  INTEGER*4 I,LBYTE
;		      BYTE B			  BYTE B
;		      I = 255			  I = 255
;		      B = I			  B = LBYTE(I)
;
;	.INDEX ARITHMETIC CONVERSIONS>>
;
;	Alan L. Zirkle     Naval Surface Weapons Center
;			   Code K53
;	19 Jan 1986	   Dahlgren, Virginia  22448
;

	.ENTRY	LBYTE,^M<>

	CVTBL	@4(AP),R0

	RET

;;
;	INTEGER FUNCTION ARG_ADDRESS( n )
;
;
;	Returns, as the function result, the virtual address  of  the  Nth
;	argument  passed  to  the  routine which called ARG_ADDRESS.  This
;	address will be zero if N > the total number of  arguments  passed
;	or  if  the Nth argument was omitted [as is the second argument in
;	'CALL X(A,,B)' ].  'N' is an integer in the range (1,255).
;
;	NOTE--Character  string  arguments  to  FORTRAN subprograms cannot
;	      ever be omitted unless the corresponding dummy  argument  is
;	      either  non-existent  or  not  of character data type.  This
;	      means that such arguments can only  be  'passed  through' to
;	      another subprogram, by using the mechanism:
;
;			SUBROUTINE A
;			ADDR=ARG_ADDRESS(1)
;			IF (ADDR.NE.0) CALL B(%VAL(ADDR))
;
;	      (This does work for character constant  strings,  since  the
;	       FORTRAN  compiler  and the linker conspire to change actual
;	       character string arguments to  hollerith  when  the  formal
;	       argument  is  not of type CHARACTER.  This is documented in
;	       the FORTRAN manual.)
;
;	.INDEX ARGUMENTS>>
;
;	Alan L. Zirkle     Naval Surface Weapons Center
;			   Code K53
;	28 Jun 1982	   Dahlgren, Virginia  22448
;

	.ENTRY	ARG_ADDRESS, ^M<>

	MOVZBL	@4(AP),R0	; VALUE OF N IS NOW IN R0

	BEQL	BAD		; ZERO IS NOT LEGAL VALUE FOR N

	CMPB	R0,@8(FP)	; 8(FP) IS CALLER'S AP

	BGTRU	BAD		; BRANCH IF N > TOTAL NUMBER OF ACTUAL ARGS

	MOVL	@8(FP)[R0],R0	; GET Nth ACTUAL ARGUMENT ADDRESS--IT WILL
				;  BE ZERO IF THE ARGUMENT DOESN'T EXIST
	RET

BAD:	CLRL	R0		; THE ARGUMENT DOESN'T EXIST--RETURN ZERO

	RET

;;
;	INTEGER FUNCTION NARGS()
;
;
;	Returns, as the function result, the number  of  actual  arguments
;	passed to the routine which called NARGS. Omitted actual arguments
;	[as in 'CALL X(A,,B)' ] are counted in this total.
;
;	.INDEX ARGUMENTS>>
;
;	Alan L. Zirkle     Naval Surface Weapons Center
;			   Code K53
;	28 Jun 1982	   Dahlgren, Virginia  22448
;

	.PSECT	$CODE, LONG,PIC,SHR,EXE,RD,NOWRT


	.ENTRY	NARGS, ^M<>

	MOVZBL	@8(FP),R0	; 8(FP) IS CALLER'S AP

	RET


	.END