.MCALL	.MODULE
.NLIST CND
.IIF NDF IFRE$R IFRE$R = 0
.IF EQ IFRE$R
.MODULE	IGETR,VERSION=12,COMMENT=<IGETR/SYSLIB>,IDENT=NO,LIB=YES
.IFF; EQ IFRE$R
.MODULE	IFREER,VERSION=12,COMMENT=<IFREER/SYSLIB>,IDENT=NO,LIB=YES,GLOBAL=.IFRER
.ENDC; EQ IFRE$R

; Copyright (c) 1998 by Mentec, Inc., Nashua, NH.
; All rights reserved
;
; This software is furnished under a license for use only on a
; single computer system and  may  be  copied  only  with  the
; inclusion of the above copyright notice.  This software,  or
; any other copies thereof, may not be provided  or  otherwise
; made available to any other person except for  use  on  such
; system and to one who agrees to these license  terms.  Title
; to  and  ownership of the software shall at all times remain
; in Mentec, Inc.
;
; The information in this document is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation, or Mentec, Inc.
;
; Digital and Mentec  assume  no  responsibility for the use or
; reliability of its software on equipment which is not supplied
; by Digital  or Mentec,  and listed  in the  Software  Product
; Description.
;+
;COND
;
;	IFRE$R (0)	Generate IGETR
;	IFRE$R  1	Generate IFREER
;-
;++
;
;	Edit	Who	Date		Description of modification
;	----	---	----		---------------------------
;	001	WLD	17-OCT-90	Standardize PSECT names.
;--
.SBTTL	Call diagram
.REM	%
IGETR::						DOILA1:<---------------------+
	CALL	FIRST2	     +----------------->DOILAG:			     |
	BCS	DOILAG-------+				BR	ERROR--+     |
	BEQ	DOILTY-----+-)-----------+----->DOILTY:		       |     |
	BCS	DOILTY-----+ |		 |		BR	ERROR--+     |
	CALL	@R1 [$NXADR] | +---------)----->DOILAD:		       |     |
	BCS	DOILAG-------+ |	 |		BR	ERROR--+     |
	BNE	DOILAD---------+   +-----)----->DOERRI:		       |     |
	CALL	$NXVAL		   |	 |		BMI	DOERRB-)-+   |
	CALL	RCHUNK		   |	 |			       | |   |
CRRG:<-----------------------------)-+	 |		BR	FIXSP--)-)-+ |
20$:<--------------------+ +-------)-)---)----->DOERRB:<---------------)-+ | |
	.CRRG		 | |	   | |	 |		CALL	$ERRM0 |   | |
	BCC	MAP----+ | |	   | |	 |		BR	FIXSP--)---+ |
	BNE	DOERRB-)-)-+	 +-)-)---)----->DONOCH:		       |   | |
	.TWAIT	       | | |	 | | |	 |		BR	FIXSP--)---+ |
	BR	20$----)-+ |	 | | | +-)----->DONE:		       |   | |
		       |   | +---)-)-)-)-)----->FIXSP:<----------------)---+ |
MAP:<------------------+   | |	 | | | | |		CALL	WRAPUP |     |
	CALL	$NXVAL	   | |	 | | | | |			       |     |
	CALL	RCHUNK	   | |	 | | | | |			       |     |
	.CRAW		   | |	 | | | | |	ERROR:<----------------+     |
	BCC	10$----+   | |	 | | | | |	RETURN			     |
D1ERRB:		       |   | |   | | | | |				     |
	BEQ	DOERRB-)---+ |	 | | | | |	WRAPUP:			     |
FIXSP1:		       |   | |	 | | | | |		CALL	ELRG	     |
	BR	FIXSP--)---)-+	 | | | | |		.CLOSE		     |
		       |   | |	 | | | | |		CALL	IFREEC	     |
10$:<------------------+   | |	 | | | | |		RETURN		     |
	CALL	$NXADR     | |   | | | | |				     |
	BEQ	ELLOOP-----)-)-+ | | | | |	ELRG:			     |
	CALL	$NXVAL     | | | | | | | |		.ELRG		     |
	BEQ	INISUB---+ | | | | | | | |		RETURN		     |
	BGE	INIRD--+ | | | | | | | | |				     |
INICHN:		       | | | | | | | | | |	FIRST2:			     |
	CALL	[IGETC]| | | | | | | | | |		CALL  [$NXADR]	     |
	BMI	DONOCH-)-)-)-)-)-+ | | | |		BCS	DOILA1-------+
	.LOOKUP	       | | | | |   | | | |		CALL  [$NXADR]
	BCS	DOERRI-)-)-)-)-)---+ | | |		RETURN
INIRD:<----------------+ | | | |   | | | |
	.READ[W]	 | | | |   | | | |	IFREER::
	BCS	DOERRI---)-)-)-)---+ | | |		CALL	FIRST2
	BR	FIXADR-+ | | | |     | | +-------------<BNE	DOILTY
		       | | | | |     | |		CALL	ELRG
INISUB:<---------------)-+ +-)-)-----)-)---------------<BCS	DOERRB
	CALL	[users]|   | | |     | +---------------<BR	DONE
FIXADR:<---------------+   | | |     | |
ELLOOP:<-------------------)-)-+     | |	RCHUNK:
	BEQ	DONE-------)-)-------)-+		RETURN
	CALL	ELRG	   | |	     |
	BCC	CRRG-------)-)-------+
	BEQ	D1ERRB-----+ |
	BR	FIXSP1-------+
%
.SBTTL	IGETR - FORTRAN callable system subroutine
;+
;	IGETR
;
;	IGETR is used to attach to a global region.  It can
;	optionally also initialize a global region either by
;	reading in a portion of a file into it, or calling a
;	user specified subroutine.
;
;	Calling Sequence:
;
;I=IGETR(WORK,{'Private'},NAME,ADDR[,CSIZE][,MSIZE][,OFFSET][[{,CHAN[,BLK]]})
;             {'Shared' }                                   {[,FILE[,BLK]]}
;             {'Age'    }                                   {[,SBRTN,-1]] }
;
;
;	Arguments:
;
; INTEGER*2 WORK (7)		! Work area, must be passed to IFREER
; Char Constant			! 'Private' indicates not shared
;				! 'Shared' indicates shared
;				! 'Age' indicated shared and aged
; INTEGER*2 NAME (2)		! Name of global region in 6 RAD50 chars
; INTEGER*2 ADDR		! Variable which is the region's base.  It
;				! must be on a PAR boundary (0, "20000, ...).
; INTEGER*2 CSIZE		! Creation size of global region in words.
;				! this will be rounded up to nearest 32
;				! word boundary.  0 means use actual region
;				! size, invalid if region must be created.
; INTEGER*2 MSIZE		! The number of words to map, 0 or omitted
;				! indicates all of the (rest) of the region.
;				! It is rounded up to the next 32 word bound.
; INTEGER*2 OFFSET		! The offset in chunks (64. byte units) from
;				! the beginning of the global region to
;				! begin mapping.  0 means begin at beginning.
; INTEGER*2 CHAN		! Open channel to read initialization data
;				! from.  [This arg is a channel number if
;				! its value is 0 to 255. and IBLK is not -1]
; INTEGER*2 FILE (4)		! DBLK containing the device and file
;				! specification for a file to open and read
;				! initialization data from. [This arg is a
;				! DBLK if the value in the first word is
;				! greater than 255. and IBLK is not -1]
; EXTERNAL SBRTN		! Subroutine to be called to initialize the
;				! global area.  The subroutine is called with
;				! two arguments (ADDR, ISIZE).  [This arg is
;				! a subroutine if IBLK is -1]
; INTEGER*2 BLK			! The first block to use in the file for
;				! initialization of the global area.  Use
;				! 0 as the value if the entire file is to be
;				! loaded.  -1 is reserved to be used as the
;				! subroutine indicator.
;
;	NOTE: any required handler must be loaded or prefetched, IGETR
;	will not fetch any handlers.
;
;	Outputs:
;
;0	Success
;
;-1	Invalid ADDR alignment (detected by IGETR)
;
;-2	No WDB for .CRAW (-.CRAW)
;-3	Any .CRAW error except No WDB (-2)
;
;-4	EOF on .READW (-.READW-4)
;-5	I/O Error on .READW (-.READW-4)
;-6	Channel closed when .READW attempted (-.READW-4)
;-6	No Chan available from IGETC
;
;-7	No RCB for .CRRG (-.CRRG)
;-8	Insufficient memory for .CRRG (-.CRRG)
;-9	<reserved> 0 Size create (will be reported as Region not found, -11)
;-10	Memory too fragmented to return at .ELRG (-.ELRG)
;-11	Global region not found (and no non-zero SIZE specified) (-.CRRG)
;-12	No GRCB for .CRRG (-.CRRG)
;-13	Global region in use (-.ELRG) (from IFREER)
;-14	<reserved> Global Region private (Not reported, IGETR hangs in a loop)
;
;-15	.LOOKUP found channel already open (-.LOOKUP-15)
;-16	.LOOKUP could not find requested file (-.LOOKUP-15)
;-17	.LOOKUP found device in use and not sharable (-.LOOKUP-15)
;
;-18	Any .ELRG error except Mem Frag (-10)
;
;-19	First char of TYPE invalid (Not "P", "S", or "A")
;-20	Required argument is missing (IWORK, ITYPE, NAME, or ADDR)
;
; JFW 27-Dec-84
;-
	.PSECT	SYS$I,I

	.GLOBL	$SYSLB			;Display library version number
	.GLOBL	$NXADR	$NXVAL		;Routines to access arguments
	.GLOBL	$ERRM0			;Routine to return error codes
	.GLOBL	CALL$F			;Routine to call FORTRAN calling
					; conventions while saving registers
.IF EQ IFRE$R
	.GLOBL	IGETC			;Routines to allocate/free channel
.ENDC ;EQ IFRE$R
	.GLOBL		IFREEC		;Routines to allocate/free channel

	.MCALL	.CKXX	.ASSUME	.BR	;Assumption checking macros
	.CKXX	<R0,R1,R3,R5,SP>
	.MCALL	.RDBDF			;Define names in RDB block
	.MCALL	.WDBDF			;Define names in WDB block
	.MCALL	.CRRG	.TWAIT	.CRAW
	.MCALL	.LOOKUP	.READC	.ELRG
	.MCALL	.CLOSE
	.RDBDF
	.WDBDF
F.ARGS	=:	-2		;offset from parm base to parm count
F.PMTR	=	2		;offset from R5 to parm base
NOARG	=:	-1		;value of omitted addr
PWORK	=:	0		;Work area
PTYPE	=:	2		;Access type
	TYPEA	=:	'A	;Age
	TYPEE	=:	'E	;Eliminate
	TYPEP	=:	'P	;Private
	TYPES	=:	'S	;Shared
PNAME	=:	4		;2 words of RAD50 region name
PADDR	=:	6		;Address to map it into
PCSIZE	=:	10		;Creation SIZE in words
PMSIZE	=:	12		;Mapping size in words
POFFST	=:	14		;Offset value in chunks
PINIT	=:	16		;ICHAN/IFILE/SBRTN address
PIBLK	=:	20		;Block offset in file
	ISSBRTN	=:	-1	;Subroutine indicator

;SYSCOM REFERENCES

ERRBYT	=:	52		;EMT error byte

;ERROR VALUES

SUCCES	=:	0		;Successful completion
ILADDR	=:	-1.		;ADDR not on PAR boundary
ERWDB	=:1 ;	-2.		;No WDB for .CRAW
ILCRAW	=:	-3.		;.CRAW error other than 1
ERREAD	=:4 ;	-4.		;.READW EOF
	;	-5.		;.READW I/O error
	;	-6.		;.READW Channel closed
ILCHAN	=:	-6.		;No channel available from IGETC
ERRCB	=:6 ;	-7.		;.CRRG no RCB available
ERMEM	=:7 ;	-8.		;.CRRG insufficient memory
	;	-9.		;<reserved>
ERFRAG	=:11 ;	-10.		;.ELRG memory too fragmented to return
ERGRNF	=:12 ;	-11.		;.CRRG Global region not found
				; (and ISIZE specfied as 0)
ERGRCB	=:13 ;	-12.		;.CRRG no GRCB available
	;	-13.		;<reserved>
	;	-14.		;<reserved>
ERPRIV	=:15 ;			;.CRRG Region exists, but is private (loop)
ERLOOK	=:17 ;	-15.		;.LOOKUP channel in use
	;	-16.		;.LOOKUP file not found
	;	-17.		;.LOOKUP device in use and not sharable
ILELRG	=:22 ;	-18.		;.ELRG error other than 11
ILTYPE	=:	-19.		;Unknown TYPE letter
ILLARG	=:	-20.		;Missing required Argument
;	WORK AREA LAYOUT
W.GID	=:	R.GID		;Id word in RDB
W.GSIZ	=:	R.GSIZ		;Region size word in RDB
W.GSTS	=:	R.GSTS		;Status word in RDB
W.GNAM	=:	R.GNAM		;Region name (2 RAD50 words) in RDB
;*** The following definition line should be replaced by the line following it
;*** when base address support is added.  The work area will have to grow by a
;*** word.
W.SP	=:	R.GBAS		;Saved SP in work area
;W.SP	=:	R.GLGH		;Saved SP in work area
W.CHAN	=:	W.SP+2		;Channel number in use
W.LENG	=:	W.CHAN+2	;Size, in bytes, of work area
GETR$W	==:	W.LENG/2	;Global def of number of words in work area

;	Stack alignment control
S.RET	=:	1000		;Stack value at entry (1000 used to
				;prevent confusion with arg offsets)
NEXADR	=:	1234		;test value for $NXADR in reg

PAR2T	=:	160000		;Valid PAR PART (PAR**2T) of an address
				;used to check for proper alignment

CHUNK	=:	100		;Size of memory management unit

UCASE	=:	040		;Bit to clear to uppercase a letter

.CRAW	=:	36*400+2	;CRAW request code
.CRRG	=:	36*400+0	;CRRG request code
.ELRG	=:	36*400+1	;ELRG request code
.LOOKUP	=:	1*400+0		;LOOKUP request code
.READ	=:	10*400+0	;READx request code
.TWAIT	=:	24*400+0	;TWAIT request code

;The following bit definition must not clash with RS.* bits

SHARE	=:	1		;Indicate sharing request
DOELRG	=:	2		;Indicate ELRG on error
DOFREC	=:	4		;Indicate IFREEC on error
DOCLOS	=:	10		;Indicate CLOSE on error

LOCAL	=:	SHARE!DOELRG!DOFREC!DOCLOS
RDBBIT	=:	RS.CRR!RS.UNM!RS.NAL!RS.NEW!RS.GBL!RS.CGR!RS.AGE!RS.EGR!RS.EXI
					.ASSUME LOCAL&RDBBIT EQ 0

.IF EQ IFRE$R
.SBTTL	Get all the arguments
.ENABLE	LSB
							CK.R5=F.ARGS
							CK.SP=S.RET
IGETR::
	CALL	FIRST2		;Get first 2 arguments
							CK.R1=NEXADR
							CK.R3=W.GID
							CK.R5 F.ARGS,+2+2+2
	BCS	DOILAG
							CK.R3 W.GID
	MOV	SP,W.SP(R3)	;Save SP for error recovery
	CMPB	#TYPEA,R0	;Is it "Age"?
	BNE	10$		;No
	BIS	#<RS.GBL!RS.AGE!SHARE>,R2 ;Indicate global, aging, and share
10$:
	CMPB	#TYPEP,R0	;Is it "Private"?
	BNE	20$		;No
	BIS	#RS.GBL,R2	;Indicate global
20$:
	CMPB	#TYPES,R0	;Is it "Share"?
	BNE	30$		;No
	BIS	#<RS.GBL!SHARE>,R2 ;Yes, indicate sharing
30$:
	TST	R2		;Any bits set?
							CK.SP S.RET
	BEQ	DOILTY		;No, unknown TYPE specified
							CK.R1 NEXADR
							CK.R5 PNAME,+2
	CALL	@R1		;Point to region name
							CK.SP S.RET
	BCS	DOILAG		;Required argument missing
							CK.R3 W.GID
	MOV	(R0)+,W.GNAM(R3) ;Put in name area
							CK.R3 W.GID
	MOV	@R0,W.GNAM+2(R3) ; ...
							CK.R1 NEXADR
							CK.R5 PADDR,+2
	CALL	@R1		;Get address
							CK.SP S.RET
	BCS	DOILAG		;Required argument missing
	BIT	#^cPAR2T,R0	;Is it aligned on a PAR boundary?
							CK.SP S.RET
	BNE	DOILAD		;No, invalid address
	MOV	R0,R1		;Save the address in R1
							CK.R1=152525;not NEXADR

	CLR	R0		;Assume no size, default to 0
							CK.R5 PCSIZE,+2
	CALL	$NXVAL		;Get area size value
	ASL     R0		;Convert words into bytes for Rchunk
	CALL	RCHUNK		;Round and change to chunks
							CK.R3 W.GID
	MOV	R0,W.GSIZ(R3)	;Put in RDB

;R1=ADDR, R2=RDB_status, R3=WORK, R4=arg_count, R5=arg_pointer
.SBTTL	Create/attach to the region
.ENABLE	LSB
;				;Cond Code set by prev MOV
	BEQ	10$		;No size specified
	BIS	#RS.CGR,R2	;Size given, allow creation
10$:
	MOV	R2,R0		;Copy bits
	BIC	#^cRDBBIT,R0	;Save only RDB status bits
							CK.R3 W.GID
	MOV	R0,W.GSTS(R3)	;Put status bits in request RDB
CRRG:
							S.ACRR=CK.SP
							CK.R3 W.GID
							CK.SP ,-2,S.RDB
	MOV	R3,-(SP)	;Put addr of RDB on stack
							CK.SP ,-2,S.CREQ
	MOV	#.CRRG,-(SP)	;Put request code on stack
20$:
							CK.SP S.CREQ
						.ASSUME S.CREQ+2 EQ S.RDB
	.CRRG	SP,CODE=NOSET	;Try to create/attach to region
	BCC	MAP		;No error
	CMPB	#ERPRIV,@#ERRBYT ;Region private, but exists?
	BNE	DOERRB		;No, bad error

.SBTTL	Region is currently 'Private', wait and retry

							S.ATIM=CK.SP
							CK.SP ,-2,S.TIME
	MOV	#TIME,-(SP)	;Put addr of ticks on stack
							CK.SP ,-2,S.TREQ
	MOV	#.TWAIT,-(SP)	;put request code on stack
							CK.SP S.TREQ
						.ASSUME S.TREQ+2 EQ S.TIME
	.TWAIT	SP,CODE=NOSET	;Bide a wee
;	BCS			;Ignore errors
							CK.SP ,+2+2
	CMP	(SP)+,(SP)+	;Remove .TWAIT request from stack
							CK.SP S.ATIM
	BR	20$		;try to attach again
							CK.SP S.CREQ
.SBTTL	Error processing and exit

.IFTF ;EQ IFRE$R
DOILA1:				;Called with an extra word on the stack
	TST	(SP)+		;Align stack
DOILAG:
	MOV	#ILLARG,R0	;Load error code
	BR	ERROR

DOILTY:
	MOV	#ILTYPE,R0	;Load error code
	BR	ERROR

.IFT ;EQ IFRE$R
DOILAD:
	MOV	#ILADDR,R0	;Load error code
	BR	ERROR

DOERRI:
	MOVB	@#ERRBYT,R4	;Get Error byte value
	BMI	DOERRB		;SERR code
	ADD	R4,R0		;Add in offset
	NEG	R0		;make error code negative
	BR	FIXSP		;return the value

.IFTF ;EQ IFRE$R
DOERRB:
	SEC			;Insure carry is set
	CALL	$ERRM0		;Use standard EMT error routine
	BR	FIXSP

.IFT ;EQ IFRE$R
DONOCH:
	MOV	#ILCHAN,R0	;Load error code
	BR	FIXSP

.IFTF ;EQ IFRE$R
DONE:
	CLR	R0		;SUCCESS!
							CK.R3=W.GID
FIXSP:
						CK.R3 W.GID
	MOV	W.SP(R3),SP	;Clean up stack (really!!)
	MOV	R0,-(SP)	;Save return value
	CALL	WRAPUP		;Do possible cleanup stuff
	MOV	(SP)+,R0	;Return it
ERROR:
	RETURN
.IFT ;EQ IFRE$R
.SBTTL	Create window and map to region
.ENABLE	LSB

MAP:
							CK.SP ,+2+2
							CK.SP S.ACRR
	CMP	(SP)+,(SP)+	;Remove .CRRG request from stack
							S.ACRA=CK.SP
							CK.SP ,-2,S.NSTS
	MOV	#WS.MAP,-(SP)	;W.NSTS = map it, too
	CLR	R0		;Default MSIZE to 0
							CK.R5 PMSIZE,+2
	CALL	$NXVAL		;Pick up possible Mapping SIZE
	ASL	R0		;Convert words into bytes for Rchunk
	CALL	RCHUNK		;Round and change to chunks
	TST	R0		;Test R0 for zero
	BEQ     10$		;If zero compute default
							CK.R3 W.GID
	CMP	W.GSIZ(R3),R0	;Is msize within Csize?
	BGE	20$		;If it is then proceed else pretend it was 0
10$:
							CK.R3 W.GID
	MOV     W.GSIZ(R3),R0	;Move the size of the region into msize.
20$:
							CK.SP ,-2,S.NLEN
	MOV	R0,-(SP)	;Put Msize onto the stack
				;Compute the Offset value
	CLR	R0		;Default offset is 0
							CK.R5 POFFST,+2
	CALL	$NXVAL		;Pick up possible Offset value in chunks
							CK.SP ,-2,S.NOFF
	MOV	R0,-(SP)	;W.NOFF = OFFSET in chunks
							CK.R3 W.GID
							CK.SP ,-2,S.NRID
	MOV	@R3,-(SP)	;W.NRID = W.GID	
							CK.SP S.NRID
							CK.SP ,-2,S.NSIZ
	MOV	S.NLEN-S.NRID(SP),-(SP) ;Use adjusted MSIZE for for W.NSIZ
							CK.SP ,-2,S.NBAS
	MOV	R1,-(SP)	;Copy par addr into W.NBAS
	MOV	R1,R0		;Copy for manipulation
	ASH	#-5,R0		;Convert address to PAR number in high byte
	BIC	#^c7*400,R0	;Clear any sign extend
							CK.SP ,-2,S.NID
	MOV	R0,-(SP)	;W.NAPR = PAR num (high byte)
							S.NAPR=CK.SP+1
							S.WDB=CK.SP
;	Following instruction is different on different processors
;	it is replaced by the next two instructions
;	MOV	SP,-(SP)	;Put addr of WDB on stack
	MOV	SP,R0		;Save addr of WDB in R0
							CK.R0=S.WDB
							CK.SP ,-2,S.AWDB
	MOV	R0,-(SP)	;Put addr in request block on stack
							CK.SP ,-2,S.CREQ
	MOV	#.CRAW,-(SP)	;Put request code on stack
.ENABLE	LSB
							CK.SP S.CREQ
						.ASSUME S.CREQ+2 EQ S.AWDB
						.ASSUME	S.WDB EQ S.NID
						.ASSUME S.NID+1 EQ S.NAPR
						.ASSUME S.NAPR+1 EQ S.NBAS
						.ASSUME S.NBAS+2 EQ S.NSIZ
						.ASSUME S.NSIZ+2 EQ S.NRID
						.ASSUME S.NRID+2 EQ S.NOFF
						.ASSUME S.NOFF+2 EQ S.NLEN
						.ASSUME S.NLEN+2 EQ S.NSTS
	.CRAW	SP,CODE=NOSET	;Create a window and map to it
	BCC	10$		;No error
	CMPB	@#ERRBYT,#ERWDB	;Was it no WDB?
D1ERRB:	BEQ	DOERRB		;Yes, return negative of code
	MOV	#ILCRAW,R0	;Load generic .CRAW error code
FIXSP1:	BR	FIXSP		;Return fixed error code
10$:
	MOV	S.NSIZ-CK.SP(SP),R0 ;Get actual size mapped
	ASH	#+5,R0		;Change count from chunks to words
	ADD	#<S.ACRA-CK.SP>,SP ;Clean up stack
 						CK.SP ,+<S.ACRA-CK.SP>
						CK.SP S.ACRA
						CK.SP ,-2,S.NSIZ
	MOV	R0,-(SP)	;And save it on the stack for later

.SBTTL	See if we need to init it, and if so how

	BIT	#RS.NEW,W.GSTS(R3) ;Did we just create the region?
DONE1:	BEQ	DONE		;No, no need to init (or share)
							CK.SP ,-2,S.PADD
	MOV	R1,-(SP)	;Put ADDR on stack

	MOV	#NOARG,R0	;Assume no ICHAN/IFILE/SUBRN address
							CK.R5 PINIT,+2
	CALL	$NXADR		;Get address of ICHAN/IFILE/SUBRN
	CMP	#NOARG,R0	;Was any initialization requested?
	BEQ	ELLOOP		;No, no need to init
				; (but we might have to share)
	BIS	#DOELRG,R2	;Indicate .ELRG required on error
	MOV	R0,R1		;Copy given address to R1

	CLR	R0		;Assume no IBLK
							CK.R5 PIBLK,+2
	CALL	$NXVAL		;Get Value of IBLK
	MOV	R0,R4		;Copy given value

;R1=ICHAN/IFILE/SUBRN, R2=ITYPE, R3=WORK, R4=IBLK, @SP=ADDR, 2(SP)=ISIZE

	CMP	#ISSBRTN,R4	;Is this a subroutine to call?
							S.ZSUB=CK.SP
	BEQ	INISUB		;Yes, do it
	CMP	#255.,@R1	;It it a channel number?
	BLO	INICHN		;no, go get one
	MOV	@R1,R1		;get value instead of address
	BR	INIRD		;yes, no need to open it
.SBTTL	Setup for .LOOKUP (and call IGETC)
.ENABLE	LSB

INICHN:
							S.ALOO=CK.SP
							CK.SP ,-2,S.SEQN
							S.ZERO=CK.SP
	CLR	-(SP)		;No Args for IGETC AND SEQNUM = 0
	MOV	SP,R5		;Point to 0
							CK.R5=CK.SP
							CK.SP ,-2,S.DBLK
	MOV	R1,-(SP)	;DBLK = IFILE
							CK.SP ,-2,S.LREQ
	MOV	#.LOOKUP,-(SP)	;Put request code on stack
	MOV	#IGETC,R0	;Call IGETC
							CK.R5=S.ZERO
	CALL	CALL$F		;Call a FORTRAN subroutine
	MOV	R0,R1		;Copy channel number allocated
	BMI	DONOCH		;None available
	BIS	#DOFREC,R2	;Set flag in TYPE reg to indicate IFREEC
							CK.SP S.LREQ
	MOVB	R1,@SP		;Put in channel number
							CK.R3 W.GID
	MOVB	R1,W.CHAN(R3)	;And save it for error exits
							CK.SP S.LREQ
						.ASSUME S.LREQ+2 EQ S.DBLK
						.ASSUME S.DBLK+2 EQ S.SEQN
	.LOOKUP	SP,CODE=NOSET	;Lookup the file
	MOV	#ERLOOK,R0	;*C*Load offset value
DOERR1:	BCS	DOERRI		;Add in offset, then standard error stuff
	BIS	#DOCLOS,R2	;Set flag in TYPE reg to indicate close
	ADD	#<S.ALOO-CK.SP>,SP ;Clean stack
							CK.SP ,+<S.ALOO-CK.SP>
							CK.SP S.ALOO
.SBTTL	Read in data from open channel
.ENABLE	LSB

INIRD:
							S.AREA=CK.SP
							CK.SP S.PADD
	MOV	@SP,R0		;Copy ADDR from stack
						.ASSUME	CK.SP+2 EQ S.NSIZ
	MOV	2(SP),R5	;Copy ISIZE from stack
							CK.SP ,-2,S.CRTN
	CLR	-(SP)		;CRTN = 0 (.READW)
							CK.SP ,-2,S.WCNT
	MOV	R5,-(SP)	;WCNT = ISIZE
							CK.SP ,-2,S.BUF
	MOV	R0,-(SP)	;BUF = ADDR
							CK.SP ,-2,S.BLK
	MOV	R4,-(SP)	;BLK = IBLK
							CK.SP ,-2,S.RREQ
	MOV	#.READ,-(SP)	;request code to stack
							CK.SP S.RREQ
	MOVB	R1,@SP		;Put in channel number
							CK.R3 W.GID
	MOVB	R1,W.CHAN(R3)	;And save it for error exits
							CK.SP S.RREQ
						.ASSUME S.RREQ+2 EQ S.BLK
						.ASSUME S.BLK+2 EQ S.BUF
						.ASSUME S.BUF+2 EQ S.WCNT
						.ASSUME S.WCNT+2 EQ S.CRTN
	.READC	SP,CODE=NOSET	;Read into the region
	MOV	#ERREAD,R0	;*C*Load offset value
	BCS	DOERR1		;Error
	ADD	#<S.AREA-CK.SP>,SP ;Clean stack
							CK.SP ,+<S.AREA-CK.SP>
							CK.SP S.AREA
	BR	FIXADR		;Reload ADDR then, check for sharing

.SBTTL	Call the user's routine to init the area
.ENABLE	LSB
							CK.SP=S.ZSUB
INISUB:
							CK.SP ,-2,S.TWO
	MOV	SP,R5		;Store pointers to the pushed parameters
				;for the fortran subroutine.
	TST	(R5)+		;Move pointer to second parameter value.
	MOV	R5,-(SP)	;Push pointer to second parameter
	TST	-(R5)		;Move pointer to first parameter value.
	MOV	R5,-(SP)	;Push pointer to first parameter.
	MOV	#2,-(SP)	;Push Arg count.
	MOV	SP,R5		;Point to arg list
							CK.R5=CK.SP
	MOV	R1,R0		;Point to user's routine
							CK.R5 S.TWO
						.ASSUME S.TWO+2 EQ S.PADD
						.ASSUME S.PADD+2 EQ S.NSIZ
	CALL	CALL$F		;Call it
							CK.SP ,+2
	TST	(SP)+		;Clean up the stack
	CMP	(SP)+,(SP)+
							CK.SP S.ZSUB
FIXADR:
							CK.SP S.PADD
	MOV	@SP,R1		;Restore ADDR
.SBTTL	Check for sharing, if so .ELRG, and begin again
.ENABLE	LSB

ELLOOP:
	BIC	#DOELRG,R2	;Indicate .ELRG not required on error
							CK.R3 W.GID
	BIT	#RS.NEW,W.GSTS(R3) ;Did we just create the region?
	BEQ	DONE1		;No, then nothing special for sharing it
	BIT	#SHARE,R2	;Are we sharing?
	BEQ	DONE1		;No, then nothing special to do
	CALL	ELRG		;Eliminate the region
	BCC	10$		;No error
	CMPB	@#ERRBYT,#ERFRAG ;Was it too fragmented to return memory?
	BEQ	D1ERRB		;Yes, return negative of code
	MOV	#ILELRG,R0	;Load generic .ELRG error code
	BR	FIXSP1		;Return generic .ELRG error
10$:
	JMP	CRRG		;Try creation loop again
.IFTF ;EQ IFRE$R
.SBTTL	WRAPUP routine

.ENABLE	LSB

WRAPUP:
	BIT	#DOELRG,R2	;ELRG needed?
	BEQ	10$		;No
							CK.R3 W.GID
	BIS	#RS.EGR,R.GSTS(R3) ;Yes, do a global eliminate
	CALL	ELRG		;Eliminate the region
;	BCS			;Ignore errors on wrapup
10$:
							CK.R3 W.GID
	MOVB	W.CHAN(R3),R1	;Get channel number
	BIT	#DOCLOS,R2	;Do a close?
	BEQ	20$		;No
	.CLOSE	R1		;Close the channel
;	BCS			;Ignore errors
20$:
	BIT	#DOFREC,R2	;Do a IFREEC?
	BEQ	40$		;No
							S.AFRE=CK.SP
							CK.SP ,-2,S.CHAN
	MOV	R1,-(SP)	;Put channel number on stack
	MOV	SP,R1		;Push a pointer to the value onto the stack.	
	MOV	R1,-(SP)	;MOV SP,-(SP)
	MOV	@SP,R1		;Put R1 back after using it.
							CK.R1=CK.SP
							CK.R1 S.CHAN
							CK.SP ,-2,S.ACHN
							CK.SP ,-2,S.ONE
	MOV	#1,-(SP)	;Indicate a single arg
	MOV	SP,R5		;Point to arg list
							CK.R5=CK.SP
	MOV	#IFREEC,R0	;Point to routine to call
							CK.R5 S.ONE
						.ASSUME S.ONE+2 EQ S.ACHN
	CALL	CALL$F		;Call it
							CK.SP ,+2
	TST	(SP)+		;realign stack
;	TST	R0		;Ignore errors
;	BMI			;...
	BR	30$		;Pop 2 words and return
							CK.SP S.AFRE-2-2
ELRG:
							S.AELR=CK.SP
							CK.SP ,-2,S.RDB
	MOV	R3,-(SP)	;Put RDB addr on stack
							CK.SP ,-2,S.EREQ
	MOV	#.ELRG,-(SP)	;Put request code on stack
							CK.SP S.EREQ
						.ASSUME S.EREQ+2 EQ S.RDB
	.ELRG	SP,CODE=NOSET	;Do a local eliminate
	BIC	#DOELRG,R2	;*C*Indicate ELRG not needed???
30$:
							CK.SP ,+2+2
	BIT	(SP)+,(SP)+	;*C*Clean stack
40$:
	RETURN
.SBTTL	FIRST2 -- Get first 2 arguments and do some init'ing

.ENABLE	LSB
							CK.R5=F.ARGS
							CK.SP=S.RET+2
FIRST2:
	MOV	#$NXADR,R1	;Point to subroutine
							CK.R5 F.ARGS,+2
	MOV	(R5)+,R4	;Get count, point to first arg
							CK.R5 PWORK,+2
	CALL	@R1		;Point to work area
							CK.R0=W.GID
							CK.SP S.RET+2
	BCC	10$		;IWORK found
	JMP	DOILA1		;Required argument missing (stack not aligned)
10$:
	MOV	R0,R3		;Save work area pointer

							CK.R3=CK.R0
							CK.R5 PTYPE,+2
	CALL	@R1		;Point to type letter
	BCS	20$		;Required argument missing
	MOVB	@R0,R0		;Load the first byte
	BIC	#UCASE,R0	;Force uppercase
	CLR	R2		;Assume nothing
;	CLC			;From CLR above
20$:
	RETURN

.IFT ;EQ IFRE$R
.ENABLE	LSB

RCHUNK:
	CMP	#-<CHUNK-1-1>,R0 ;Will rounding "clear" it?
	BLO	10$		;Yes, so skip rounding
	ADD	#CHUNK-1,R0	;Round size up to nearest chunk
	ASH	#-6,R0		;Convert from word count to chunk count
	BIC	#^c1777,R0	;Clear any sign extend
	RETURN
10$:
	MOV	#2000,R0	;Handle problem case
	RETURN
.IFF ;EQ IFRE$R
.SBTTL	IFREER - FORTRAN callable system subroutine
;+
;	IFREER
;
;	IFREER is used to detach from a global region.  It can
;	optionally also eliminate a global region.  A request
;	to eliminate a global region may not actually eliminate
;	a region, but it will remove the connection between the
;	job and the global region.
;
;	Calling Sequence:
;
; I = IFREER (IWORK [, 'Eliminate'])
;
;	Arguments:
;
; INTEGER*2 IWORK (\TBD\)	! Work area, must be passed from IGETR
; Char Constant			! omitted, disconnect, do not eliminate
;				! 'Eliminate' attempt to elim region
;	Outputs:
;
;0	Success
;
;-10	Memory too fragmented to return at .ELRG (-.ELRG)
;-11	Global region not found (-.ELRG)
;-18	Any .ELRG error except Mem Frag (-10) and reg not found (-11)
;
;-19	First char of TYPE invalid (Not "E")
;-20	Required argument is missing (IWORK)
;-21	.SERR -1 error
;-22	.SERR -2 error 
;...	...
;
; JFW 25-Feb-25
;-

.ENABLE	LSB
							CK.R5=F.ARGS
							CK.SP=S.RET
IFREER::
	CLR	R2		;Indicate no wrapup services needed
	CALL	FIRST2		;Get the arguments
							CK.R3=W.GID
	BCS	10$		;No second arg, no eliminate
							CK.R3 W.GID
	MOV	SP,W.SP(R3)	;Save SP for error recovery
	CMPB	#TYPEE,R0	;Is it an eliminate request?
	BNE	DOILTY		;No
							CK.R3 W.GID
	BIS	#RS.EGR,R.GSTS(R3) ;Yes, do a global eliminate
10$:
	CALL	ELRG		;Do the .ELRG request
	BCS	DOERRB		;Error
	BR	DONE		;Else success
.IFT ;EQ IFRE$R
	.PSECT	SYS$S,D

TIME:	.WORD	0,5		;Wait 5 ticks
.ENDC ;EQ IFRE$R
.END