Google
 

Trailing-Edge - PDP-10 Archives - BB-H138F-BM_1988 - 7-sources/lodlod.b36
There are 3 other files named lodlod.b36 in the archive. Click here to see a list.
%TITLE 'L O A D E R  - RMSLOD loading routines'
!<BLF/REQUIRE 'RMSBLF.REQ'>
MODULE loader (IDENT = '1'
		) =
BEGIN
!
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1986.
!	ALL RIGHTS RESERVED.
!
!	THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!	COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND 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.  NO TITLE TO AND OWNERSHIP OF  THE
!	SOFTWARE IS HEREBY TRANSFERRED.
!
!	THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!	NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!	EQUIPMENT CORPORATION.
!
!	DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!	ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!
!++
! FACILITY:	RMSLOD
!
! ABSTRACT:
!
!	LOADER contains the routines which take an input file (specified
!	by a FAB) and an empty RMS indexed file (again, a FAB) and yield
!	a loaded RMS indexed file.  The file fill limits will be observed,
!	allowing both efficient reading and efficient writing.  LOADER may
!	call SORT if secondary keys are present.
!
! ENVIRONMENT:	User mode, but probably as a Dynamic Library eventually.
!
! AUTHOR: Ron Lusk , CREATION DATE: 30-Aug-84
!
! MODIFIED BY:
!
!	, : VERSION
! 01	-
!       20-Sep-85 asp - Cleanup after Ron's departure to the seminary.
!--

!
! TABLE OF CONTENTS
!

FORWARD ROUTINE
    lodlod,					! Internal loading entry point
    print_stats,				! Print out statistics
    rmslod,					! External call entry point
    do_load,					! Called by both entry points
    get_pid,					! Return a PID from the system
    init_rms_blocks,				! Isolated to keep it clean
    cleanup,					! Close files
    brfile,					! Build an RMS file
    bldidx,					! Build one index of the file
    primary_index,				! Build the primary index
    do_udrs,					! Create user data records
    do_data_bucket,				! Allocate a data bucket
    extract_secondary_key,			! Extract keys from UDR
    do_idr,					! Make an index record
    do_index_bucket,				! Allocate an index bucket
    secondary_index,				! Build an alternate index
    sort_tag_file,				! Sort the extracted keys
    generate_tag_file_name,			! Name a tag file uniquely
    do_sidrs,					! Create all SIDR records
    do_rfa,					! Handle duplicate keys
    create_tag_file,				! Make file for extracted keys
    open_key_file,				! Prepare sorted key file
    read_data,					! Read a primary input record
    read_key_file,				! Read the sorted key file
    sec_xcp_rec,				! Process a duplicate alt. key
    do_xcp_rec,					! Process an illegal UDR
    do_mrg_rec,					! Process an out-of-order UDR
    lodinp,					! Read data internally
    rmserr,					! RMS error signaller
    utlerr,					! $UTLINT error signaller
    lodhdl;					! Condition handler

!
! INCLUDE FILES:
!

LIBRARY 'rmssys';

LIBRARY 'bli:tops20';

LIBRARY 'bli:xport';

LIBRARY 'bli:fao';

LIBRARY 'utllib';

!
! MACROS:
!

KEYWORDMACRO
    $signal_error (
	    status_code = 0,			! Default to generalized error
	    control,				! FAO control string
	    p1 = 0,
	    p2 = 0,
	    p3 = 0,
	    p4 = 0,
	    p5 = 0,
	    p6 = 0 ) =
	BEGIN
	LOCAL
	    faoprms : VECTOR [5];
	!
	!   Set up parameters
	!
	faoprms [0] = (p1);
	faoprms [1] = (p2);
	faoprms [2] = (p3);
	faoprms [3] = (p4);
	faoprms [4] = (p5);
	!
	!   Signal the error
	!
	SIGNAL ((status_code), $fao_ctl (control), faoprms)
	END %;

MACRO
    $trace [] = %,
!	BEGIN
!	IF .typeout
!	THEN
!	    psout ($stptr (' * * * >', %REMAINING, %CHAR(13,10)));
!	END %,
    $tracei [] = %,
!	BEGIN
!	IF .typeout
!	THEN
!	    psout ($stptr ('--->    ', %REMAINING, %CHAR(13,10)));
!	END %,
    $traceo [] = %;
!	BEGIN
!	IF .typeout
!	THEN
!	    psout ($stptr ('    <---', %REMAINING, %CHAR(13,10)));
!	END %;

MACRO
    $copy_words ($$from, $$to, $$length) =
	BEGIN

	BUILTIN
	    machop;

	LITERAL
	    $xblt_opcode = %O'020',
	    $extend_opcode = %O'123';

	BIND
	    extinst = UPLIT ($xblt_opcode^27);

	REGISTER
	    R1 = 1,
	    R2 = 2,
	    R3 = 3;

	R1 = ($$length);			! Length in words
	R2 = ($$from);				! Source
	R3 = ($$to);				! Destination
	machop ($extend_opcode, R1, extinst);	! Move the data
	R1 = .R1;				! Dummy move
	R2 = .R2;				! ...
	R3 = .R3;				! ...
	END %,
    !
    !	Generate a pointer to a literal string
    !
    $stptr [] =
 CH$PTR (UPLIT (%ASCIZ %STRING (%REMAINING))) %,
    !
    !	Move a bucket descriptor from one place to another swiftly
    !
    $move_bucket_descriptor (xfrom, xto) =
    BEGIN
    BUILTIN
    	machop;
    REGISTER
	R1 = 1,
	R2 = 2;
    BIND
	xx$$from = (xfrom),
	xx$$to = (xto);
    R1 = 0;					! Dummy
    R2 = 0;					! ...
    $dmove (R1, xx$$from);			! Fetch descriptor
    $dmovem (R1, xx$$to);			! Store it away
    R1 = .R2;					! Dummy 
    END %;

!+
!   $LOD_TAG_RECORD defines a buffer, the first word of which
!   is the RFA of a UDR, the remaining words contain a secondary
!   key of that UDR.  The TAG_RECORD is written to a tag file.
!-

FIELD
    tag$r_fields =
	SET
	tag$g_rfa = [0, 0, 36, 0],		! RFA of key
	tag$t_key = [1, 0, 0, 0]		! Beginning of key
	TES;

LITERAL
    tag$k_bln = rms$k_max_key_words + 1;

MACRO
    $lod_tag_record =
 BLOCK [tag$k_bln] FIELD (tag$r_fields) %;

!+
!   $LOD_INPUT_DESCRIPTOR is the descriptor of the input
!   record returned by the record input routine (whether
!   RMSLOD's internal routine or a user routine) which
!   specifies the record's address, length in bytes, and
!   length in words.
!-

FIELD
    inp$r_fields = 				! Input record descriptor
	SET
	inp$h_bytes = [0, 0, 18, 0],		! Length in bytes
	inp$h_words = [0, 18, 18, 0],		! Length in words
	inp$a_section = [1, 18, 18, 0],		! Data's section
	inp$a_address = [1, 0, 18, 0],		! Data's in-section address
	inp$a_data = [1, 0, 36, 0]		! Address of data
	TES;

LITERAL
    inp$k_bln = 2;

MACRO
    $lod_input_descriptor =
 BLOCK [inp$k_bln] FIELD (inp$r_fields) %;

!
! EQUATED SYMBOLS:
!

BIND
    work_area = CH$PTR (UPLIT (%ASCIZ'LOD$WORK'));	! Logical name

BIND
    xcp$t_too_big = $fao_ctl (			!
	    'XCP record !SL (input record !SL) rejected because !/', 	!
	    '!_record size (!SL) is greater than maximum allowed (!SL)!/'),
    xcp$t_too_small = $fao_ctl (		!
	    'XCP record !SL (input record !SL) rejected because !/', 	!
	    '!_record size (!SL) is less than minimum required (!SL)!/'),
    xcp$t_not_mrs = $fao_ctl (			!
	    'XCP record !SL (input record !SL) rejected because !/', 	!
	    '!_record size (!SL) does not equal fixed record size (!SL)!/'),
    xcp$t_illegal_dup = $fao_ctl (		!
	    'XCP record !SL (input record !SL) rejected because !/', 	!
	    '!_duplicate primary keys are not allowed!/'),
    xcp$t_ill_sec_dup = $fao_ctl ('XCP record !SL rejected because !/', 	!
	    '!_duplicate keys not permitted for key !SL!/');

LITERAL
    lod$_success = 1,
    lod$_no_data = 2,
    lod$_bug = 0,
    lod$k_inbuf_count = 5,			! Input buffers to use
    input_buffer_length = %O'2000',		! Big (but dynamic!)
    list_buffer_length = 300/5,			! 300 characters across
    fname_buffer_length = 90/5,			! 90 characters across
    srtcmd_buffer_length = 132/5,		! 132 characters across
    key_buffer_length = rms$k_max_key_words;

!
! OWN STORAGE:
!

OWN
    lodsec,					! Section we're in
    rmssec,					! Section RMS is in
    usrsec,					! Section caller is in
    !
    !   I/O structures
    !
    infab : REF $fab_decl,			! Input FAB
    inrab : $rab_decl,				! Input RAB
    outfab : REF $fab_decl,			! Output FAB
    outrab : $rab_decl,				! Output RAB
    xcp_fab : $fab_decl,			! Exception record FAB
    xcp_rab : $rab_decl,			!     "       "    RAB
    mrg_fab : $fab_decl,			! Out-of-order record FAB
    mrg_rab : $rab_decl,			!      "         "    RAB
    lst_fab : $fab_decl,			! Listing file FAB
    lst_rab : $rab_decl,			!    "     "   RAB
    ttyfab : $fab_decl,				! TTY output FAB
    ttyrab : $rab_decl,				!  "    "    RAB
    input_rtn,					! Input routine address
    error_rtn,					! User error routine
    in_rec : $lod_input_descriptor,		! Describes input
    !
    !   Tag file structures
    !
    tag_fab : VECTOR [rms$k_max_keys],		! Pointers to tag FABs
    tag_rab : VECTOR [rms$k_max_keys],		! Pointers to tag RABs
    tag_record : $lod_tag_record,		! Tag record buffer
    key_fab : $fab_decl,			! For reading tag files
    key_rab : $rab_decl,			! ...
    !
    !   Record counters
    !
    input_count,				! Records read
    loaded_count,				! Records in output file
    mrg_count,					! Records loaded later
    xcp_count,					! Error records
    !
    !   Flags, etc.
    !
    print_messages : VOLATILE,			! For error handler
    typeout : INITIAL (0),			! For debugging
    eof,					! End of File flag
    secondary_dup,				! If newkey EQL oldkey
    tag_file_created : BITVECTOR [rms$k_max_keys + 1],	! Set if opened
    !
    !   Conversion factors and other odd storage
    !
    inpbpw,					! Input bytes-per-word
    outbpw,					! Output bytes-per-word
    idrlen,					! Set as each key processed
    sidrlen,					! SIDR length (hdr+key,no RFA)
    minimum_data_size,				! Minimum legal record length
    number_of_keys,				! Keys in file
    udr_header_length,				! Fix=2, Var=3
    udr_length,					! Total length of UDR
    output_bytes,				! Converted from input bytes
    rfa : $rms_rfa,				! Current RFA
    pid,					! PID of this process
    !
    !   Buffers and pointers
    !
    input_buffer : REF VECTOR [input_buffer_length],	! Dynamically allocated
    key_buffer : VECTOR [key_buffer_length],	! Current key here
    hikey_buffer : VECTOR [key_buffer_length],	! HIKEY for this index here
    key_ptr,					! Pointer to key buffer
    !
    !	Arguments for calls to FAO
    !
    control,					! Address of control string
    faoprm : VECTOR [15],			! Parm-list for $FAOL calls
    !
    !	Buffer variables for the LIS file
    !
    lstlen,					! Length of output
    lstbuf : VECTOR [list_buffer_length],	! List file buffer
    lstdsc : $str_descriptor (class = fixed, 	! Buffer descriptor for
	    string = (list_buffer_length*5, 	! error listing
	    CH$PTR (lstbuf))),			!
    !
    !	Buffer variables for building filenames
    !
    fn_buf : VECTOR [fname_buffer_length],	! Tag file name buffer
    fn_dsc : $str_descriptor (class = fixed, 	! Buffer descriptor for
	    string = (fname_buffer_length*5, 	! tag-file name
	    CH$PTR (fn_buf))),			!
    !
    !	Buffer variables for building the commands for SORT
    !
    srtbuf : VECTOR [srtcmd_buffer_length],	! SORT command buffer
    srtdsc : $str_descriptor (class = fixed, 	! Buffer descriptor for
	    string = (srtcmd_buffer_length*5, 	! SORT command
	    CH$PTR (srtbuf))),			!
    srtlen,					! Length of SORT command
    srtsts,					! Status returned from SORT
    !
    !	Buffer variables for TTY: output
    !
    ttylen,					! Length of output
    ttybuf : VECTOR [list_buffer_length],	! TTY: buffer
    ttydsc : $str_descriptor (class = fixed, 	! Buffer descriptor for
	    string = (list_buffer_length*5, 	! TTY:
	    CH$PTR (ttybuf))),			!
    !
    !	Buffer variables for the error handler;
    !	FAB and RAB, too
    !
    errctl,					! FAO control string
    errprm : VECTOR [4],			! FAO parameters
    errbuf : VECTOR [list_buffer_length],	! Same purpose, same size
    errfab : $fab (fna = 'TTY:', fac = put),
    errrab : $rab (fab = errfab, ubf = errbuf),
    errdsc : $str_descriptor (			! Buffer descriptor for
	    string = (list_buffer_length*5, 	!   errors
	    CH$PTR (errbuf))),			! ...
    errlen,					! Length of FAO output
    !
    !   Internal RMS structures
    !
    kdb : REF $rms_kdb,				! Current KDB
    !
    !   Variables indexed by number of level in index
    !
    curbkt : BLOCKVECTOR [rms$k_max_levels, bkt$k_bln]	!
	FIELD (bkt$r_fields),			! Current bucket on level
    lstbkt : BLOCKVECTOR [rms$k_max_levels, bkt$k_bln]	!
	FIELD (bkt$r_fields),			! Previous bucket on level
    nxtrec : VECTOR [rms$k_max_levels],		! Next record location
    currec : VECTOR [rms$k_max_levels],		! This record location
    freespace : VECTOR [rms$k_max_levels];	! Space left in bucket

!
! EXTERNAL REFERENCES:
!

EXTERNAL LITERAL
    ss$unw;					! Condition value for CHF

EXTERNAL ROUTINE
    mapit,					! Jump to extended addressing
    demap,					! Come back to section 0
    freexabs,					! Free dynamic XABs
    sort : FORTRAN_SUB,				! SORT interface
    getmem,					! Get some memory
    fremem;					! Free some memory
%SBTTL 'Routine LODLOD'

GLOBAL ROUTINE lodlod (p_infab, p_outfab) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	LODLOD is the internal routine which calls the
!	RMSLOD Load routines.  It enables a condition
!	handler, sets up parameters into own storage,
!	and then calls DO_LOAD.  At the end of all
!	things, it then prints out statistics for
!	the current run.
!
! FORMAL PARAMETERS
!
!	P_INFAB	    - input FAB for file to be read
!	P_OUTFAB    - output FAB describing file to be built
!
! IMPLICIT INPUTS
!
!	None I can think of
!
! ROUTINE VALUE:
!
!	LOD$_SUCCESS	- successful operation
!	LOD$_BUG	- internal error
!
! SIDE EFFECTS:
!
!	Statistics are printed out
!
!--

    BEGIN

    LOCAL
	lodsts;					! Status of LODLOD call

    !
    !   Set up the parameters so that they are
    !	available throughout DO_LOAD.
    !
    infab = .p_infab;				! INFAB for DO_LOAD
    outfab = .p_outfab;				! OUTFAB
    input_rtn = 0;				! Input routine (may be 0)
    error_rtn = 0;				! Error record routine
    !
    !	Put us into a non-zero section
    !
    sdvec ($fhslf, 0);				! Clear section 0 RMS
    mapit ();					! Map us to section 1
    $init;					! Get extended RMS
    !
    !	What sections do we and RMS occupy, respectively?
    !
    BEGIN

    BUILTIN
	machop;

    REGISTER
	R1;

    $xmovei (R1, %O'20');			! Will get us section number
    lodsec = .R1;				! Get the address
    lodsec<0, 18> = 0;				! Leave the section number
    END;
    !
    !	Get RMS's section
    !
    BEGIN

    LOCAL
	ev_length,				! Length of Entry Vector
	ev_address;				! Address of EV

    xgsev_ ($xsevd^18 or $fhslf;		! Get the entry vector
	ev_length, ev_address);			! ...
    rmssec = .ev_address<18, 11>^18;		! Get the section number
    END;
    usrsec = 0;					! No user section
    !
    !	Set up a FAB/RAB combo to write to the user.
    !
    $fab_init (fab = ttyfab, fac = put, fna = 'TTY:');
    $rab_init (rab = ttyrab, fab = ttyfab, ubf = ttybuf, rbf = ttybuf);
    $open (fab = ttyfab);
    $connect (rab = ttyrab);
    !
    !	Because we are running interactively, we
    !	can print messages to the user.
    !
    print_messages = 1;
    !
    !	We are in non-zero space, have our section numbers,
    !	and have moved the parameters around.  Let us hope
    !	that that is enough and load the file.
    !
    lodsts = do_load ();			! Load the file proper
    !
    !	Check the status anyway
    !

    SELECTONE .lodsts OF 			! Check status
	SET

	[lod$_success] :
	    BEGIN
	    print_stats ();			! Let the user know how he did
	    $close (fab = ttyfab);		! Close the TTY:
	    demap ();				! Back to section 0
	    freexabs (.outfab [fab$a_xab]);	! Free our XABs
	    RETURN lod$_success;		! And we shall succeed as well
	    END;

	[lod$_no_data] :
	    BEGIN
	    !
	    !	Put out an informatory message
	    !
	    control = $fao_ctl ('!/[No valid input data was found]!/');
	    $faol (ctrstr = .control, outlen = ttylen, 	! Format it
		outbuf = ttydsc, prmlst = 0);
	    ttyrab [rab$h_rsz] = .ttylen;	! Set record length
	    $put (rab = ttyrab);
	    !
	    !	Undo things
	    !
	    $close (fab = ttyfab);		! Close error reporting
	    demap ();				! Back to section 0
	    freexabs (.outfab [fab$a_xab]);	! Free our XABs
	    RETURN lod$_success;		! We did OK
	    END;

	[lod$_bug] :
	    BEGIN
	    !
	    !	Undo things
	    !
	    $close (fab = ttyfab);
	    demap ();				! Back to section 0
	    freexabs (.outfab [fab$a_xab]);	! Free our XABs
	    RETURN lod$_bug;			! Return error
	    END;
	TES;

    1
    END;					! End of LODLOD
%SBTTL 'Routine RMSLOD'

GLOBAL ROUTINE rmslod (p_infab, p_outfab, p_input_rtn, p_error_rtn) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	RMSLOD is the Dynamic Library interface to the
!	RMSLOD Load routines.  It enables a condition
!	handler, sets up parameters into OWN storage,
!	and then calls DO_LOAD.
!
! FORMAL PARAMETERS
!
!	P_INFAB	    - input FAB for file to be read
!	P_OUTFAB    - output FAB describing file to be built
!	P_INPUT_RTN - address of the user's input routine
!	P_ERROR_RTN - address of routine to call if error occurs
!
! IMPLICIT INPUTS
!
!	None I can think of
!
! ROUTINE VALUE:
!
!	LOD$_SUCCESS	- successful operation
!	LOD$_BUG	- internal error
!
! SIDE EFFECTS:
!
!	N
!--

    BEGIN
    !
    !	Start immediately by checking our section number.
    !	We must be in a non-zero section if this routine
    !	has been called.
    !
    BEGIN

    BUILTIN
	machop;

    REGISTER
	R1;

    $xmovei (R1, %O'20');			! Will get us section number
    lodsec = .R1;				! Get the address
    lodsec<0, 18> = 0;				! Leave the section number
    END;

    IF .lodsec EQL 0				! Section zero?
    THEN
	RETURN 0;				! Horrid failure

    !
    !   Set up the parameters so that they are
    !	available throughout DO_LOAD.
    !
    infab = .p_infab;				! INFAB for DO_LOAD
    outfab = .p_outfab;				! OUTFAB
    input_rtn = .p_input_rtn;			! Input routine (may be 0)
    error_rtn = .p_error_rtn;			! Error record routine
    $init;					! Get extended RMS
    !
    !	What section does RMS occupy?
    !
    BEGIN

    LOCAL
	ev_length,				! Length of Entry Vector
	ev_address;				! Address of EV

    xgsev_ ($xsevd; ev_length, ev_address);	! Get the entry vector
    rmssec = .ev_address<18, 11>^18;		! Get the section number
    END;
    !
    !	Get the user's section number
    !
    usrsec = .p_input_rtn;			! Use user's routine as guide
    usrsec<0, 18> = 0;
    print_messages = 0;				! No output allowed
    !
    !	We are in non-zero space, have our section numbers,
    !	and have moved the parameters around.  Let us hope
    !	that that is enough and load the file.
    !
    RETURN do_load ();				! Load the file proper
    END;					! End of RMSLOD
%SBTTL 'Routine PRINT_STATS'
ROUTINE print_stats =
    BEGIN
    !
    !   Write out the final statistics
    !
    control = $fao_ctl ('!/!7SL input record!%S read!/');
    faoprm [0] = .input_count;
    $faol (ctrstr = .control, outbuf = ttydsc, 	!
	prmlst = faoprm, outlen = ttylen);
    ttyrab [rab$h_rsz] = .ttylen;		! Length of output
    ttyrab [rab$a_rbf] = ttybuf;		! Address of data
    $put (rab = ttyrab);
    control = $fao_ctl ('!7SL record!%S loaded into file!/');
    faoprm [0] = .loaded_count;
    $faol (ctrstr = .control, outbuf = ttydsc, 	!
	prmlst = faoprm, outlen = ttylen);
    ttyrab [rab$h_rsz] = .ttylen;		! Length of output
    ttyrab [rab$a_rbf] = ttybuf;		! Address of data
    $put (rab = ttyrab);

    IF .mrg_count NEQ 0				! Print only if some merged
    THEN
	BEGIN
	control = $fao_ctl ('!7SL out-of-order record!%S merged into file!/');
	faoprm [0] = .mrg_count;
	$faol (ctrstr = .control, outbuf = ttydsc, 	!
	    prmlst = faoprm, outlen = ttylen);
	ttyrab [rab$h_rsz] = .ttylen;		! Length of output
	ttyrab [rab$a_rbf] = ttybuf;		! Address of data
	$put (rab = ttyrab);
	END;

    IF .xcp_count NEQ 0				! Only if we have some
    THEN
	BEGIN
	control = $fao_ctl ('!7SL error record!%S written to XCP file!/', 	!
	    '!_!_(See RMSLOD.LIS for error information)!/');
	faoprm [0] = .xcp_count;
	$faol (ctrstr = .control, outbuf = ttydsc, 	!
	    prmlst = faoprm, outlen = ttylen);
	ttyrab [rab$h_rsz] = .ttylen;		! Length of output
	ttyrab [rab$a_rbf] = ttybuf;		! Address of data
	$put (rab = ttyrab);
	END;

    RETURN lod$_success;
    END;					! End of PRINT_STATS
%SBTTL 'Routine DO_LOAD'

GLOBAL ROUTINE do_load =

!++
! FUNCTIONAL DESCRIPTION:
!
!       RMSLOD zeroes the several record counters; clears
!       the EOF flag; and checks for the presence of input
!       data, issuing an error message if there are no
!       valid input records.  If there is valid input data,
!       DO_LOAD calls BRFILE to do the heavy work.
!
! FORMAL PARAMETERS
!
!
!       INPUT_FAB	- address of FAB for input file,
!        		  or 0 if "release load" being done.
!       OUTPUT_FAB	- address of FAB for skeleton index
!        		  file; any existing file will be
!        		  superseded.
!       INPUT_ROUTINE	- for "release load": this is caller's
!        		  routine, which is called to fill
!        		  our record buffer, rather than
!        		  using INPUT_FAB, etc.
!
!
! IMPLICIT INPUTS
!
!	EOF	- end of current file (primary input file,
!		  in this case); used to check for existence
!		  of valid data in input file.
!
! ROUTINE VALUE:
!
!	LOD$_SUCCESS	- normal termination
!	LOD$_NO_DATA	- no input data
!	LOD$_BUG	- internal error
!
! SIDE EFFECTS:
!
!	INPUT_COUNT, LOADED_COUNT, MRG_COUNT, XCP_COUNT all
!	initially set to zero; reflect appropriate values on
!	return.  Data file read to EOF on return; loaded
!	RMS indexed file exists.
!
!--

    BEGIN

    ENABLE
	lodhdl (print_messages);

    $tracei ('DO_LOAD');
    !
    !	Initialize EOF
    !
    eof = false;
    !
    !	Get our PID
    !
    pid = get_pid ();

    !+
    !	Open the MRG, XCP, and LST files
    !-

    init_rms_blocks ();				! Set up FABs, RABs
    $create (fab = mrg_fab, err = rmserr);
    $connect (rab = mrg_rab, err = rmserr);
    $create (fab = xcp_fab, err = rmserr);
    $connect (rab = xcp_rab, err = rmserr);
    $create (fab = lst_fab, err = rmserr);
    $connect (rab = lst_rab, err = rmserr);
    !
    !	Zero the several record counters.
    !
    input_count = loaded_count = mrg_count = xcp_count = 0;
    !
    !	Allocate the buffer we need
    !
    input_buffer = getmem (input_buffer_length);
    !
    !   Open the input file, if one exists.
    !

    IF .input_rtn EQL 0				! No user input routine?
    THEN
	BEGIN
	$open (fab = .infab, err = rmserr);	! Open the input file
	$rab_init (rab = inrab, rac = seq, fab = .infab, 	!
	    rop =  rah, mbf = lod$k_inbuf_count, ! 8/5/85 asp
	    ubf = (.lodsec OR .input_buffer), usz = input_buffer_length);
	$connect (rab = inrab, err = rmserr);	! Create record stream
	END
    ELSE
	BEGIN

	IF .infab EQL 0				! No input FAB
	THEN
	    RETURN $signal_error (		! We need more data
		    status_code = lod$_bug, 	! Input fab needed
		    control = '?No input FAB provided');

	END;

    !
    !   Create the output file
    !
    outfab [fab$v_sup] = 1;			! Supersede existing file
    $create (fab = .outfab, err = rmserr);	! Create file
    $rab_init (rab = outrab, rac = key, 	! Keyed output
	rop = loa, fab = .outfab, 		! Load limits
	ubf = (.lodsec OR .input_buffer), 	! Our buffer (not much used)
	usz = input_buffer_length);		! ...
    $connect (rab = outrab, err = rmserr);	! Connect a record stream
    !
    !   Set up the bytes-per-word for
    !   both input and output files
    !
    inpbpw = 36/.infab [fab$v_bsz];
    outbpw = 36/.outfab [fab$v_bsz];
    !
    !   Set up the UTLINT environment
    !
    $utl_setenv (rab = .lodsec OR outrab, 	! Always returns TRUE
	error = utlerr);			! ...we hope
    !
    !   Set up the minimum data record length, etc.
    !
    kdb = $utl_getkdb (key_of_reference = 0, error = utlerr);

    IF .kdb EQL 0				! Failure
    THEN
	RETURN $signal_error (status_code = lod$_bug, 	!
		control = '?Cannot get KDB 0 for output file !J!/', 	!
		p1 = .outfab [fab$h_jfn]);

    kdb = .rmssec OR .kdb;			! Cross-section reference
    minimum_data_size = .kdb [kdb$h_minimum_rsz];
    !
    !   Get the prologue for the number of keys
    !
    BEGIN

    LOCAL
	prol_desc : $rms_bucket_descriptor,
	fpt : REF $rms_fpt;

    $utl_getbkt (bucket_no = 0, 		! Get prologue bucket
	bucket = .lodsec OR prol_desc, 		! ...
	error = utlerr);			! ...
    fpt = .rmssec OR .prol_desc [bkt$a_address];	! Map the FPT
    number_of_keys = .fpt [fpt$b_keys];		! Get the key count
    $utl_putbkt (update = 0, 			! Get rid of bucket
	bucket = .lodsec OR prol_desc, 		!   without updating it
	error = utlerr);
    END;
    !
    !   Zero the key buffer for comparisons
    !
    key_ptr = CH$PTR (key_buffer, 0, .kdb [kdb$v_byte_size]);
    CH$FILL (0, .kdb [kdb$h_key_size_bytes], .key_ptr);
    !
    !	Get a valid input data record.  Do not check
    !	for out-of-order key on first input.
    !
    read_data (false);

    !+
    !	If EOF is still false, then we have
    !	at least one valid data record and
    !	can continue to load the file.
    !-

    IF .eof					! No data
    THEN
	BEGIN
	cleanup ();
	RETURN lod$_no_data;
	END
    ELSE
	BEGIN
	brfile ();
	cleanup ();
	RETURN lod$_success;
	END;

    END;					! End of DO_LOAD
%SBTTL 'Routine GET_PID'
ROUTINE get_pid =
    BEGIN

    LOCAL
	retval,
	pdb : VECTOR [$ipcfp + 1];		! IPCF packet descriptor block

    pdb [$ipcfl] = ip_cfb OR ip_cpd;		! Don't block; create PID
    pdb [$ipcfs] = pdb [$ipcfr] = pdb [$ipcfp] = 0;

    IF NOT msend ($ipcfp + 1, pdb)
    THEN
	retval = 0				! No PID, fake it
    ELSE
	retval = .pdb [$ipcfs];			! Return the PID

    $traceo ('GET_PID');
    RETURN .retval;
    END;					! End of GET_PID
%SBTTL 'Routine INIT_RMS_BLOCKS'
ROUTINE init_rms_blocks =
    BEGIN
    !
    !   MRG file: GET & PUT, in case we have to read later.
    !   Also, notice that RAT = BLK, so we don't really
    !   a user buffer when reading later.
    !
    $fab_init (fab = mrg_fab, fac = <get, put>, shr = nil, 	!
	bsz = .outfab [fab$v_bsz], org = seq, 	!
	fop = <sup, drj>, mrs = .outfab [fab$h_mrs], 	!
	fna = 'RMSLOD.MRG', rat = blk);
    mrg_fab [fab$v_rfm] = .outfab [fab$v_rfm];	! Move format
    $rab_init (rab = mrg_rab, fab = mrg_fab);
    !
    !	XCP file
    !
    $fab_init (fab = xcp_fab, fac = <put>, shr = nil, 	!
	bsz = .outfab [fab$v_bsz], org = seq, 	!
	fop = <sup, drj>, mrs = 0, 		!
	fna = 'RMSLOD.XCP', rfm = var);		! Variable format required
    $rab_init (rab = xcp_rab, fab = xcp_fab);
    !
    !	LST file
    !
    $fab_init (fab = lst_fab, fac = <put>, shr = nil, 	!
	bsz = 7, org = seq, 			!
	fop = <sup, drj>, mrs = 0, 		!
	fna = 'RMSLOD.LIS', rfm = stm);
    $rab_init (rab = lst_rab, fab = lst_fab);
    RETURN lod$_success;
    END;					! End of INIT_RMS_BLOCKS
%SBTTL 'Routine CLEANUP'
ROUTINE cleanup =
    BEGIN
    $tracei ('CLEANUP');

    IF .xcp_count EQL 0				! No XCP records?
    THEN
	BEGIN
	$close (fab = xcp_fab, err = rmserr);
	$close (fab = lst_fab, err = rmserr);
	xcp_fab [fab$v_drj] = 0;		! Release JFN this time
	$erase (fab = xcp_fab, err = rmserr);	! Delete the file
	lst_fab [fab$v_drj] = 0;		! Release JFN
	$erase (fab = lst_fab, err = rmserr);	! Delete file
	END
    ELSE
	BEGIN
	xcp_fab [fab$v_drj] = 0;		! Release JFN
	$close (fab = xcp_fab, err = rmserr);	! Close the file
	lst_fab [fab$v_drj] = 0;		! Release JFN
	$close (fab = lst_fab, err = rmserr);
	END;

    !+
    !	Merge the MRG records in here
    !-

    IF .mrg_count EQL 0				! Work to do?
    THEN
	BEGIN
	$close (fab = mrg_fab, err = rmserr);	! Close the file
	mrg_fab [fab$v_drj] = 0;		! Release the JFN
	$erase (fab = mrg_fab, err = rmserr);	! Erase the file
	END
    ELSE
	BEGIN
	$disconnect (rab = mrg_rab, err = rmserr);	! Reset the record stream
	$connect (rab = mrg_rab, err = rmserr);	! ...
	mrg_rab [rab$v_loc] = 1;		! Use locate mode
	mrg_rab [rab$a_ubf] = .lodsec OR .input_buffer;	! Might not need this
	mrg_rab [rab$h_usz] = input_buffer_length;

	WHILE $get (rab = mrg_rab, err = rmserr) DO 	! Loop through records
	    BEGIN
	    outrab [rab$a_rbf] = .mrg_rab [rab$a_rbf];	! Point at record
	    outrab [rab$h_rsz] = .mrg_rab [rab$h_rsz];	! Give the length
	    $put (rab = outrab, err = rmserr);
	    END;

	$close (fab = mrg_fab, err = rmserr);	! Close the MRG file
	mrg_fab [fab$v_drj] = 0;		! Release the JFN
	$erase (fab = mrg_fab, err = rmserr);	! Delete it
	END;

    !
    !   Free the buffer memory
    !
    fremem (.input_buffer, input_buffer_length);
    !
    !	Close the files
    !
    $close (fab = .infab, err = rmserr);
    $close (fab = .outfab, err = rmserr);
    $traceo ('CLEANUP');
    RETURN lod$_success;
    END;					! End of CLEANUP
%SBTTL 'Routine BRFILE'
ROUTINE brfile =

!++
! FUNCTIONAL DESCRIPTION:
!
!   	BRFILE performs several initialization
!   	functions:  it checks for and defines (if necessary)
!   	the logical name LOD$WORK:, which is used for the
!   	tag files and temporary sort files; it zeroes the
!   	tag file flags (which mark when a tag file exists);
!   	and it then calls BLDIDX for each key.  Finally,
!   	it undefines LOD$WORK if it was defined by the program.
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	KDB 	- used to keep track of current index
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- successful run
!   	LOD$_BUG    	- internal error
!
! SIDE EFFECTS:
!
!	TAG_FILE    	- all bits zeroed
!
!--

    BEGIN

    LOCAL
	ln_buf : VECTOR [50],
	we_defined_lod$work;			! Flag logical name def'n

    $tracei ('BRFILE');

    !+
    !   If system or user defined the work area, OK.
    !   Otherwise, define it ourselves, and remember
    !   that we did so.
    !-

    we_defined_lod$work = 0;			! Initialize before checking

    IF NOT lnmst ($lnsjb, 			! Check job tables
	    work_area, 				! ...
	    CH$PTR (ln_buf))			! Throw away translation
    THEN

	IF NOT lnmst ($lnssy, 			! Check system tables
		work_area, 			! ...
		CH$PTR (ln_buf))		! ...
	THEN
	    BEGIN				! Define our own

	    IF NOT crlnm ($clnjb, 		! Define job logical name
		    work_area, 			! ...
		    CH$PTR (UPLIT ('DSK:')))	! Point at DSK:
	    THEN
		RETURN $signal_error (status_code = lod$_bug, 	!
			control = '!/?Cannot define work area LOD$WORK!/')
	    ELSE
		we_defined_lod$work = 1;

	    END;

    !+
    !   Zero the tag file flags.
    !-

    BEGIN

    BIND
	tfc_words = tag_file_created : VECTOR [];

    INCR i FROM 0 TO %ALLOCATION (tag_file_created) - 1 DO
	tfc_words [.i] = 0;

    END;

    !+
    !   Cycle through the indexes, building
    !   as we go.
    !-

    kdb = $utl_getkdb (key_of_reference = 0, error = utlerr);

    DO
	BEGIN
	kdb = .rmssec OR .kdb;			! For cross-section reference
	bldidx ();				!
	kdb = $utl_getkdb (key_of_reference = (.kdb [kdb$h_reference] + 1), 	!
	    error = utlerr);
	END
    UNTIL (.kdb EQL 0);

    !+
    !   If we defined the logical name for the work area,
    !   delete it now that we don't need it any more.
    !-

    IF .we_defined_lod$work			!
    THEN
	BEGIN

	IF NOT crlnm ($clnj1, work_area, 0)	! Delete the name
	THEN
	    RETURN $signal_error (status_code = lod$_bug, 	!
		    control = '!/?Cannot undefine work area LOD$WORK!/');

	END;

    $traceo ('BRFILE');
    RETURN lod$_success;
    END;					! End of BRFILE
%SBTTL 'Routine BLDIDX'
ROUTINE bldidx =

!++
! FUNCTIONAL DESCRIPTION:
!
!   	BLDIDX sets up initial state for building
!   	an index and then calls either PRIMARY_INDEX
!   	(if the current key is 0) or SECONDARY_INDEX.
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	KDB 	- key length in words
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- all OK
!   	LOD$_BUG    	- internal error
!
! SIDE EFFECTS:
!
!	The LSTBKT and CURBKT bucket descriptors
!   	for all levels are zeroed.
!
!   	IDRLEN is set up.
!
!--

    BEGIN
    $tracei ('BLDIDX');

    !+
    !   Zero all last- and current-bucket descriptors.
    !-

    INCR level FROM 0 TO rms$k_max_levels DO
	BEGIN
	lstbkt [.level, bkt$a_address] = 0;
	curbkt [.level, bkt$a_address] = 0;
	END;

    !
    !   Set up the index record length for this index.
    !
    idrlen = .kdb [kdb$h_key_size_words] + idx$k_bln;
    !
    !   Store the HIKEY for this index in HIKEY_BUFFER
    !

    CASE .kdb [kdb$v_datatype]			! Determine by datatype
    FROM xab$k_stg				! ...
    TO xab$k_bn4 OF 				! ...
	SET

	[xab$k_stg, xab$k_ebc, xab$k_as8, xab$k_six] :
	    !
	    !   Character types
	    !
	    BEGIN

	    LOCAL
		char_ptr;

	    char_ptr = CH$PTR (			! Build a pointer
		hikey_buffer, 			! Start here
		0, 				! No offset
		.kdb [kdb$v_byte_size]);	! Character byte size
	    !
	    !   Fill the HIKEY buffer
	    !
	    CH$FILL (-1, .kdb [kdb$h_key_size_bytes], .char_ptr);
	    END;

	[xab$k_pac] :
	    BEGIN

	    LOCAL
		char_ptr;

	    char_ptr = CH$PTR (hikey_buffer, 0, 9);	! Pointer for packed
	    !
	    !   Fill the HIKEY buffer.  %O'231' is a 9-bit
	    !   value equivalent to packed '99'.
	    !
	    CH$FILL (%O'231', .kdb [kdb$h_key_size_bytes], .char_ptr);
	    !
	    !	Locate the sign byte
	    !
	    char_ptr = CH$PTR (hikey_buffer, 	! Start here
		.kdb [kdb$h_key_size_bytes] - 1, 	! Point at this byte
		9);				! Use 9-bit pointer
	    !
	    !   Deposit a '9+' into the last byte
	    !
	    CH$WCHAR (%O'234', .char_ptr);
	    END;

	[xab$k_in4, xab$k_fl1] :
	    hikey_buffer = %O'377777777777';

	[xab$k_in8, xab$k_fl2, xab$k_gfl] :
	    hikey_buffer [0] = hikey_buffer [1] = %O'377777777777';

	[xab$k_bn4] :
	    hikey_buffer = -1;			! Highest unsigned integer
	TES;

    !+
    !   Call the appropriate routine to build
    !   the index we want.
    !-

    IF .kdb [kdb$h_reference] EQL 0		! Primary or secondary key?
    THEN
	primary_index ()			! It's primary
    ELSE
	secondary_index ();			! It's secondary

    !
    !	Flush all the buffers after each index
    !
    $flush (rab = outrab, err = rmserr);
    $traceo ('BLDIDX');
    RETURN lod$_success;
    END;					! End of BLDIDX
%SBTTL 'Routine PRIMARY_INDEX'
ROUTINE primary_index =

!++
! FUNCTIONAL DESCRIPTION:
!
!   	PRIMARY_INDEX builds the primary index of
!   	the RMS file.  It sets up a few things,
!   	then processes each valid input data record.
!   	After EOF is reached on the input data, the
!   	current buckets for each level are output,
!   	the root bucket is noted and the IDB's root
!   	pointer is updated to point to that bucket.
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	OUTFAB	    - the record format is read
!   	EOF 	    - to end UDR processing
!   	CURBKT - to determine the root bucket
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- all OK
!   	LOD$_BUG    	- bug somewhere
!
! SIDE EFFECTS:
!
!	UDR_HEADER_LENGTH 	- set to length appropriate for record format
!   	IDB for key 0	- root-pointer is set
!   	Indexed file	- has a primary index in it
!
!--

    BEGIN

    LOCAL
	root_level,				! Level of root bucket
	root_bucket;				! Number of root bucket

    $tracei ('PRIMARY_INDEX');
    !
    !   Set up the length of the record header,
    !   which depends on the record format of
    !   the output file.
    !

    IF .outfab [fab$v_rfm] EQL fab$k_var	! Check format
    THEN
	udr_header_length = udr$k_var_bln	! Variable is longer
    ELSE
	udr_header_length = udr$k_fix_bln;	! Don't need record length

    !
    !   Set up the length of the current data record.
    !
    udr_length = .in_rec [inp$h_words] + .udr_header_length;

    !+
    !   DO_UDRS will return at EOF.
    !-

    do_udrs ();					! Check for failure

    !+
    !   We have to finish the output of data by writing
    !   the remaining index and data buckets to the
    !   file.  While we do this, we want to
    !   keep track of the highest level encountered,
    !   because that is the root bucket.
    !-

    INCR level FROM 0 TO rms$k_max_levels DO
	BEGIN

	BIND
	    out_bucket = .rmssec OR 		!
		.lstbkt [.level, bkt$a_address] : $rms_bucket_header;

	!+
	!   Output the bucket
	!-

	$utl_putbkt (update = 1, 		! Write bucket
	    bucket = .lodsec OR lstbkt [.level, 0, 0, 0, 0], 	! ...
	    error = utlerr);			!
	!
	!   If the root flag is set, this is our root
	!

	IF .out_bucket [bhd$v_root]		! Root bucket?
	THEN
	    BEGIN
	    root_bucket = .lstbkt [.level, bkt$h_number];	! Number
	    root_level = .level;		! Levels in index
	    EXITLOOP;
	    END;

	END;

    !+
    !   Update the IDB's root pointer and level count
    !-

    BEGIN

    LOCAL
	idbptr : REF $rms_index_descriptor_block,	! Pointer to IDB
	idbbkt : $rms_bucket_descriptor;	! Bucket to hold prologue

    idbptr = $utl_getidb (bucket = .lodsec OR idbbkt, 	! Get the IDB
	error = utlerr);			! ...
    idbptr = .rmssec OR .idbptr;		! Reference across sections
    idbptr [idb$h_root] = .root_bucket;		! Update IDB
    idbptr [idb$b_levels] = .root_level;	! ...
    $utl_putbkt (update = 1, 			! Write prologue out
	bucket = .lodsec OR idbbkt, 		! ...
	error = utlerr);			! ...
    END;

    !+
    !	Close the tag files
    !-

    INCR file_number FROM 1 TO .number_of_keys - 1 DO
	BEGIN

	IF .tag_file_created [.file_number]	! Did we create a file?
	THEN
	    BEGIN
	    $close (fab = .tag_fab [.file_number], 	! Close the file
		err = rmserr);
	    !
	    !	Free the memory used by the tag-file structures
	    !
	    fremem (.tag_rab [.file_number], rab$k_bln);	! Free memory
	    fremem (.tag_fab [.file_number], fab$k_bln);	! ...
	    END;

	END;

    $traceo ('PRIMARY_INDEX');
    RETURN lod$_success;
    END;					! End of PRIMARY_INDEX
%SBTTL 'Routine DO_UDRS'
ROUTINE do_udrs =

!++
! FUNCTIONAL DESCRIPTION:
!
!   	DO_UDRS fills a data bucket by individually
!   	processing each input data record.  First,
!   	a bucket is allocated if necessary. The UDR header
!   	is created and the data is moved into the bucket.
!   	Pointers into the bucket and counts are adjusted as
!   	necessary.
!
!   	If there are alternate keys, EXTRACT_SECONDARY_KEY
!   	is called for each alternate key, to pull out that
!   	key and write it (with the current RFA) to a tag file.
!
!   	Finally, the data file is read again, and if the next
!   	record will not fit in this bucket, or if EOF is reached,
!   	an index record is generated with a call to DO_IDR.
!	DO_UDRS will return when EOF is reached.
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	CURBKT [0]	- if empty, a bucket is allocated
!   	    	    	- NEXT_ID provides the UDR_ID
!   	    	    	- the current bucket number makes the RFA
!   	IN_REC 	- WORDS: length of current record in words
!   	OUTPUT_BYTES  	- length of current record in output bytes
!
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- OK
!   	LOD$_BUG    	- internal error
!
! SIDE EFFECTS:
!
!	RFA 	    	- generated herein
!   	FREESPACE [0]	- initialized and adjusted
!   	NXTREC [0]	- " 	"
!   	CURREC [0]	- " 	"
!   	UDR_LENGTH  	- set for each record
!
!--

    BEGIN

    LOCAL
	data_bkt_hdr : REF $rms_bucket_header,
	new_record : REF $rms_user_data_record;

    $tracei ('DO_UDRS');

    DO
	BEGIN
	!
	!   Allocate a bucket, if needed
	!

	IF .curbkt [0, bkt$a_address] EQL 0	! Empty?
	THEN
	    do_data_bucket ();			! Allocate a data_bucket

	data_bkt_hdr = .rmssec OR .curbkt [0, bkt$a_address];
	!
	!   Set pointers for this new record.
	!
	currec [0] = .nxtrec [0];		! Where new record goes
	nxtrec [0] = .nxtrec [0] + .udr_length;	! Next record here

	!+
	!   Build the record header.  This comprises the flags,
	!   RRV pointer, ID, and size of the data.
	!-

	new_record = .currec [0];
	!
	!   Set the ID, and build the RFA at the same time.
	!   Also, bump the bucket's NEXT_ID.
	!
	new_record [udr$h_id] = .data_bkt_hdr [bhd$h_next_id];
	rfa [rfa$h_bucket] = .curbkt [0, bkt$h_number];
	rfa [rfa$h_id] = .data_bkt_hdr [bhd$h_next_id];
	data_bkt_hdr [bhd$h_next_id] = .data_bkt_hdr [bhd$h_next_id] + 1;
	!
	!   Set the RRV pointer and the flags.
	!
	new_record [udr$g_rrv_address] = .rfa;	! Point at self
	new_record [udr$h_flags] = udr$m_default_flags;
	!
	!   If this is a variable length record, then
	!   we have to set the record length in bytes
	!   into the next field.  If it is not variable
	!   length, there IS no next field.  We can use
	!   the UDR_HEADER_LENGTH as an indicator of format.
	!

	IF .udr_header_length EQL udr$k_var_bln	! Variable length?
	THEN
	    new_record [udr$h_size] = .output_bytes;	! Set the length

	!
	!   Move the data to the appropriate spot
	!
	$copy_words (.in_rec [inp$a_data], 	! From here
	    .currec [0] + .udr_header_length, 	! To here
	    .in_rec [inp$h_words]);		! Length in words
	!
	!   Decrement the space remaining appropriately
	!   and update the bucket header as well
	!
	freespace [0] = .freespace [0] - .udr_length;
	data_bkt_hdr [bhd$h_next_byte] = 	!
	.data_bkt_hdr [bhd$h_next_byte] + .udr_length;

	!+
	!   Process the alternate keys
	!-

	IF .number_of_keys GTR 1		! Secondary keys exist?
	THEN
	    BEGIN				! Write tag files

	    !+
	    !   Set up KDB for each key, and extract and write
	    !   the key to the tag file.
	    !-

	    INCR extract_key FROM 1 TO (.number_of_keys - 1) DO
		BEGIN
		!
		!   Get the KDB
		!

        $utl_setenv (rab = .lodsec OR outrab, 	! Always returns TRUE
	error = utlerr);			! ..we hope 8/12/85 asp 2 lines

		kdb = .rmssec OR $utl_getkdb (error = utlerr, 	!
		    key_of_reference = .extract_key);
		!
		!   Process this key
		!
		extract_secondary_key ();	!
		END;

	    !
	    !   Reset to key 0
	    !
	    kdb = .rmssec OR $utl_getkdb (key_of_reference = 0, 	!
		error = utlerr);
	    END;

	!
	!   Get the next data record, checking
	!   for out-of-order keys.
	!
	read_data (true);
	!
	!   Set up the length of the current data record.
	!
	udr_length = .in_rec [inp$h_words] + .udr_header_length;

	!+
	!   If we have reached end of file or
	!   if we have filled this bucket,
	!   then make an index record for this bucket.
	!-

	IF .eof OR 				! End-of-file?
	    (.freespace LSS .udr_length)	! Bucket full?
	THEN
	    do_idr (1);				! Generate an index record

	END
    UNTIL .eof;					! Loop until EOF

    $traceo ('DO_UDRS');
    RETURN lod$_success;
    END;					! End of DO_UDRS
%SBTTL 'Routine DO_DATA_BUCKET'
ROUTINE do_data_bucket =

!++
! FUNCTIONAL DESCRIPTION:
!
!   	DO_DATA_BUCKET allocates a data bucket; sets
!   	up the record pointers and the free-space
!   	for that bucket.  If there is a bucket in
!   	LSTBKT for the data level, the buckets
!   	will be linked and the LSTBKT output.
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	LSTBKT 	- to test for its existence
!   	KDB 	    	- data-fill-offset, to set up freespace
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- all OK
!   	LOD$_BUG    	- internal error
!
! SIDE EFFECTS:
!
!	LSTBKT 	- linked to new bucket and written to file
!   	CURBKT	- allocated brand new
!   	CURREC	- set to 0
!   	NXTREC 	- set to point at top of bucket (below header)
!   	FREESPACE   	- set up to load limit for this bucket
!
!--

    BEGIN

    LOCAL
	new_bkt_hdr : REF $rms_bucket_header;

    $tracei ('DO_DATA_BUCKET');

    $utl_setenv (rab = .lodsec OR outrab, 	! Always returns TRUE
	error = utlerr);			! ...we hope 8/6/85 asp 2 lines

    $utl_alcbkt (				! Allocate a bucket
	type = bhd$k_data, 			! Data bucket
	flags = bhd$m_end, 			! Rightmost bucket
	level = bhd$k_data_level, 		! Data level (=0)
	bucket = .lodsec OR curbkt [0, 0, 0, 0, 0], 	! Bucket descriptor
	error = utlerr);
    new_bkt_hdr = .rmssec OR .curbkt [0, bkt$a_address];

    IF .lstbkt [0, bkt$a_address] EQL 0		! No LAST-BUCKET?
    THEN
	new_bkt_hdr [bhd$h_next_bucket] = .curbkt [0, bkt$h_number]
    ELSE
	BEGIN

	LOCAL
	    old_bkt_hdr : REF $rms_bucket_header;

	!
	!   Point at the previous bucket
	!
	old_bkt_hdr = .rmssec OR .lstbkt [0, bkt$a_address];
	old_bkt_hdr [bhd$v_end] = 0;		! No longer rightmost
	!
	!   Link the buckets
	!
	old_bkt_hdr [bhd$h_next_bucket] = .curbkt [0, bkt$h_number];
	new_bkt_hdr [bhd$h_next_bucket] = .lstbkt [0, bkt$h_number];
	!
	!   Output the old bucket
	!
	$utl_putbkt (update = 1, 		! Be sure it is updated
	    bucket = .lodsec OR lstbkt [0, 0, 0, 0, 0], 	! ...
	    error = utlerr);			! ...
	lstbkt [0, bkt$a_address] = 0;		! Zero the pointer
	END;

    freespace [0] = .kdb [kdb$h_dfl_offset] - bhd$k_bln;	! Space left
    currec [0] = 0;				! No current record
    nxtrec [0] = .rmssec OR .curbkt [0, bkt$a_address]	! First free space
    + bhd$k_bln;				! Beyond bucket header
    $traceo ('DO_DATA_BUCKET');
    RETURN lod$_success;
    END;					! End of DO_DATA_BUCKET
%SBTTL 'Routine EXTRACT_SECONDARY_KEY'
ROUTINE extract_secondary_key =

!++
! FUNCTIONAL DESCRIPTION:
!
!   	EXTRACT_SECONDARY_KEY extracts the alternate keys from a
!   	primary data record and writes them to a file, tagged
!   	with the RFA of the primary data record.  It only writes
!   	keys for those records long enough to contain the key,
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- all OK
!   	LOD$_BUG    	- internal error
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN
    $tracei ('EXTRACT_SECONDARY_KEY');

    IF .output_bytes GEQ .kdb [kdb$h_minimum_rsz]	! Length OK?
    THEN
	BEGIN

	LOCAL
	    this_rab : REF $rab_decl;		! Current RAB

	IF NOT .tag_file_created [.kdb [kdb$h_reference]]	!
	THEN
	    create_tag_file (.kdb [kdb$h_reference]);

	this_rab = .tag_rab [.kdb [kdb$h_reference]];	! Point at RAB
	!
	!   Move this secondary key from the input record
	!   to the key field of the tag record.
	!
	$utl_movekey (recptr = .in_rec [inp$a_data], 	! Input record
	    keybuf = .lodsec OR tag_record [tag$t_key], 	! Tag buffer
	    error = utlerr);			! ...
	tag_record [tag$g_rfa] = .rfa;
	this_rab [rab$h_rsz] = .kdb [kdb$h_key_size_bytes]	! Key length
	+ (%BPVAL/.kdb [kdb$v_byte_size]);	! Size of RFA in bytes
	this_rab [rab$a_rbf] = tag_record;
	$put (rab = .this_rab, err = rmserr);
	END;

    $traceo ('EXTRACT_SECONDARY_KEY');
    RETURN lod$_success;
    END;					! End of EXTRACT_SECONDARY_KEY
%SBTTL 'Routine DO_IDR'
ROUTINE do_idr (this_level) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DO_IDR creates an index record from the key in
!	the key buffer.  It first allocates an index
!	bucket on level THIS_LEVEL if necessary.
!	The bucket number of the current bucket
!	on the next lower level is inserted into
!	the record header.  If EOF is set, then the
!	HIKEY flag is set and the key is set to the
!	highest possible; otherwise, the key in the key
!	buffer is moved to the index record.  Bucket space
!	counters and pointers are adjusted.  If this is
!	the last record to go into this bucket (as at EOF
!	or if the bucket is full) and this is not a root bucket,
!	then generate an index record for this bucket.
!
!	Finally, take the bucket for which we just generated
!	an index record and move its descriptor from CURBKT
!	to LSTBKT.  This reaching backwards may be confusing
!	in a way, but retirement of a bucket is associated closely
!	with the generation of an index record for it, and so
!	the operation is done here.
!
!
! FORMAL PARAMETERS
!
!	THIS_LEVEL	- level to build record on
!
! IMPLICIT INPUTS
!
!	CURBKT	- this level's current bucket
!	    NEXT_BYTE	- next word in bucket
!	EOF		- end of input file
!	NEXT_I_REC	- this level's next index record
!	FREESPACE	- this level's freespace left
!	IDRLEN - length of idx recs for this key
!	CURBKT	- previous level's current bucket
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- all OK
!   	LOD$_BUG    	- internal error
!
! SIDE EFFECTS:
!
!	New index record in CURBKT
!	NEXT_BYTE, FREESPACE, this level's record pointers updated.
!	LSTBKT on previous level holds bucket pointed at
!		by new index record.
!	CURBKT on previous level is zeroed.
!
!--

    BEGIN

    LOCAL
	idx_bkt_hdr : REF $rms_bucket_header,
	new_idx_record : REF $rms_index_record;

    $tracei ('DO_IDR');

    IF .curbkt [.this_level, bkt$a_address] EQL 0	! Do we have a bucket
    THEN
	do_index_bucket (.this_level);		! Prepare index bucket

    idx_bkt_hdr = .rmssec OR .curbkt [.this_level, bkt$a_address];
    !
    !   Set pointers for this new record
    !
    currec [.this_level] = .nxtrec [.this_level];	! New record here
    nxtrec [.this_level] = .nxtrec [.this_level] + .idrlen;

    !+
    !   Build the record header.
    !-

    new_idx_record = .currec [.this_level];	! Point at it
    new_idx_record [idx$h_bucket] = 		! Point at correct bucket
    .curbkt [.this_level - 1, bkt$h_number];

    IF .eof					! End of file (Hikey?)
    THEN
	BEGIN
	new_idx_record [idx$v_hikey] = 1;	! Set HIKEY flag
	!
	!   Move the data to the appropriate spot
	!
	$copy_words (.lodsec OR hikey_buffer, 	! From here
	    .currec [.this_level] + idx$k_bln, 	! To here
	    .kdb [kdb$h_key_size_words]);	! Length to move
	END
    ELSE
	BEGIN
	new_idx_record [idx$v_hikey] = 0;	! Clear it (just in case)
	!
	!   Move the data to the appropriate spot
	!
	$copy_words (.lodsec OR key_buffer, 	! From here
	    .currec [.this_level] + idx$k_bln, 	! To here
	    .kdb [kdb$h_key_size_words]);	! Length to move
	END;					!

    !
    !   Decrement the space remaining appropriately
    !   and update the bucket header as well
    !
    freespace [.this_level] = .freespace [.this_level] - .idrlen;
    idx_bkt_hdr [bhd$h_next_byte] = 		!
    .idx_bkt_hdr [bhd$h_next_byte] + .idrlen;

    !+
    !   If we have reached end of file, then we need
    !   to generate an index record for this bucket
    !   (unless this bucket is the root bucket, when we just
    !   move the bucket to the LSTBKT slot).
    !   If we have not reached EOF, then we need to
    !   generate an index record *for* this bucket
    !   only if there is not enough
    !   room for another record *in* this bucket.
    !-

    IF .eof					! Make index rec if needed
    THEN
	BEGIN

	IF .idx_bkt_hdr [bhd$v_root]		! Is this the root?
	THEN
	    $move_bucket_descriptor (		! Retire this bucket
		curbkt [.this_level, 0, 0, 0, 0], 	! From this descriptor
		lstbkt [.this_level, 0, 0, 0, 0])	! To this descriptor
	ELSE
	    do_idr (.this_level + 1);		! No - generate an index record

	END
    ELSE
	BEGIN

	IF .freespace [.this_level] LSS .idrlen	! More room?
	THEN
	    do_idr (.this_level + 1);		! Generate record, flush bucket

	END;

    !
    !   Move this bucket from current bucket to last bucket.
    !
    $move_bucket_descriptor (			! Retire this bucket
	curbkt [.this_level - 1, 0, 0, 0, 0], 	! From this descriptor
	lstbkt [.this_level - 1, 0, 0, 0, 0]);	! To this descriptor
    !
    !   Zero CURBKT of previous level
    !
    curbkt [.this_level - 1, bkt$a_address] = 0;
    $traceo ('DO_IDR');
    RETURN lod$_success;
    END;					! End of DO_IDR
%SBTTL 'Routine DO_INDEX_BUCKET'
ROUTINE do_index_bucket (this_level) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	DO_INDEX_BUCKET allocates an index bucket.  If there
!	is a previous bucket on this level, DO_INDEX_BUCKET
!	links the buckets together and writes out the
!	previous bucket.  If there is not a previous bucket,
!	DO_INDEX_BUCKET marks the new bucket as a root and
!	points it at itself.  Record pointers are set
!	appropriately.
!
! FORMAL PARAMETERS
!
!	THIS_LEVEL	- index level of this bucket
!
! IMPLICIT INPUTS
!
!	LSTBKT 	- BUCKET_NUMBER used in linking new bucket
!			- written to file
!	KDB		- IFL_OFFSET used in determining FREESPACE
!
! COMPLETION CODES:
!
!	LOD$_SUCCESS	- ok
!	LOD$_BUG	- internal error
!
! SIDE EFFECTS:
!
!	CURBKT	- describes new bucket
!			- ROOT set if first bucket on this level
!	LSTBKT	- linked to CURBKT
!			- ROOT cleared
!			- END cleared
!	NXTREC	- points to top of CURBKT
!	CURREC	- set to 0
!	FREESPACE	- set to index-fill-offset
!
!--

    BEGIN

    LOCAL
	new_bkt_hdr : REF $rms_bucket_header;

    $tracei ('DO_INDEX_BUCKET');
    $utl_setenv (rab = .lodsec OR outrab, 	! Always returns TRUE
	error = utlerr);			! ...we hope
    $utl_alcbkt (				! Allocate a bucket
	type = bhd$k_index, 			! Index bucket
	flags = bhd$m_end, 			! Rightmost bucket
	level = .this_level, 			! Current level
	bucket = .lodsec OR curbkt [.this_level, 0, 0, 0, 0], 	! Put it here
	error = utlerr);
    new_bkt_hdr = .rmssec OR .curbkt [.this_level, bkt$a_address];

    IF .lstbkt [.this_level, bkt$a_address] EQL 0	! No LAST-BUCKET?
    THEN
	BEGIN
	new_bkt_hdr [bhd$h_next_bucket] = 	! Point at self
	.curbkt [.this_level, bkt$h_number];
	new_bkt_hdr [bhd$v_root] = 1;		! Must be a root
	END
    ELSE
	BEGIN

	LOCAL
	    old_bkt_hdr : REF $rms_bucket_header;

	!
	!   Point at the previous bucket
	!
	old_bkt_hdr = .rmssec OR .lstbkt [.this_level, bkt$a_address];
	old_bkt_hdr [bhd$v_end] = 0;		! No longer rightmost
	old_bkt_hdr [bhd$v_root] = 0;		! No longer a root
	!
	!   Link the buckets
	!
	old_bkt_hdr [bhd$h_next_bucket] = 	! Point old at new
	.curbkt [.this_level, bkt$h_number];
	new_bkt_hdr [bhd$h_next_bucket] = 	! Point new at old
	.lstbkt [.this_level, bkt$h_number];
	!
	!   Output the old bucket
	!
	$utl_putbkt (update = 1, 		! Write it out
	    bucket = .lodsec OR lstbkt [.this_level, 0, 0, 0, 0], 	! ...
	    error = utlerr);			! ...
	lstbkt [.this_level, bkt$a_address] = 0;	! Zero the pointer
	END;

    freespace [.this_level] = .kdb [kdb$h_ifl_offset] - bhd$k_bln;	! Space available
    currec [.this_level] = 0;			! No current record
    nxtrec [.this_level] = .rmssec OR .curbkt [.this_level, bkt$a_address] + bhd$k_bln;	! First free space
    $traceo ('DO_INDEX_BUCKET');
    RETURN lod$_success;
    END;					! End of DO_INDEX_BUCKET
%SBTTL 'Routine SECONDARY_INDEX'
ROUTINE secondary_index =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	root_level,				! Level of root bucket
	root_bucket;				! Number of root bucket

    $tracei ('SECONDARY_INDEX');
    sort_tag_file ();				! Sort this file
    open_key_file (.kdb [kdb$h_reference]);	! Open the file
    !
    !   Zero the key buffer for comparisons
    !
    key_ptr = CH$PTR (key_buffer, 0, .kdb [kdb$v_byte_size]);
    CH$FILL (0, .kdb [kdb$h_key_size_bytes], .key_ptr);
    !
    !	Get the first record
    !
    read_key_file (false);			! Get a record

    IF .eof					! No records?
    THEN
	BEGIN
	$close (fab = key_fab, err = rmserr);	! Close the key file,
	key_fab [fab$v_drj] = 0;		!     release the JFN,
	$erase (fab = key_fab, err = rmserr);	!     and erase it.
	$traceo ('SECONDARY_INDEX (no data)');
	RETURN 1;
	END
    ELSE
	BEGIN
	!
	!	Set up the length of a SIDR header and key
	!	and the length of an index record.
	!
	sidrlen = sdr$k_bln + .kdb [kdb$h_key_size_words];	!
	idrlen = idx$k_bln + .kdb [kdb$h_key_size_words];
	!
	!	Process the secondary records
	!
	do_sidrs ();

	!+
	!   We have to finish the output of data by writing
	!   the remaining index and data buckets to the
	!   file.  While we do this, we want to
	!   keep track of the highest level encountered,
	!   because that is the root bucket.
	!-

	INCR level FROM 0 TO rms$k_max_levels DO
	    BEGIN

	    BIND
		out_bucket = .rmssec OR 	!
		    .lstbkt [.level, bkt$a_address] : $rms_bucket_header;	!

	    !   Output the bucket
	    !
	    $utl_putbkt (update = 1, 		! Write bucket
		bucket = .lodsec OR lstbkt [.level, 0, 0, 0, 0], 	! ...
		error = utlerr);		! ...
	    !
	    !   If the root flag is set, this is our root
	    !

	    IF .out_bucket [bhd$v_root]		! Root bucket?
	    THEN
		BEGIN
		root_bucket = .lstbkt [.level, bkt$h_number];	! Number
		root_level = .level;		! Levels in index
		EXITLOOP;
		END;

	    END;

	!+
	!   Update the IDB's root pointer and level count
	!-

	BEGIN

	LOCAL
	    idbptr : REF $rms_index_descriptor_block,	! Pointer to IDB
	    idbbkt : $rms_bucket_descriptor;	! Bucket to hold prologue

	idbptr = $utl_getidb (bucket = .lodsec OR idbbkt, 	! Get IDB
	    error = utlerr);			! ...

	IF .idbptr EQL 0			! Did this work?
	THEN
	    RETURN $signal_error (		!
		    control = '!/?Failure getting IDB for key !SL!/', 	!
		    p1 = .kdb [kdb$h_reference]);

	idbptr = .rmssec OR .idbptr;		! Reference across sections
	idbptr [idb$h_root] = .root_bucket;	! Update IDB
	idbptr [idb$b_levels] = .root_level;	! ...
	$utl_putbkt (update = 1, 		!
	    bucket = .lodsec OR idbbkt, error = utlerr);	! Write it out
	!
	!   Close and delete the input file
	!
	$close (fab = key_fab, err = rmserr);	! Close the key file,
	key_fab [fab$v_drj] = 0;		!     release the JFN,
	$erase (fab = key_fab, err = rmserr);	!     and erase it.
	END;
	$traceo ('SECONDARY_INDEX');
	RETURN lod$_success;
	END;

    END;					! End of SECONDARY_INDEX
%SBTTL 'Routine SORT_TAG_FILE'
ROUTINE sort_tag_file =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	srtarg : VECTOR [2];			! Argument for SORT

    BIND
	file_ascii = $stptr ('/ASCII'),
	file_ebcdic = $stptr ('/EBCDIC'),
	file_sixbit = $stptr ('/SIXBIT'),
	file_binary = $stptr ('/BINARY'),
	file_as8 = $stptr ('/EBCDIC /COLLATE:ASCII'),
	key_pac = $stptr (',COMP3,SIGNED'),
	key_signed = $stptr (',SIGNED'),
	key_gfl = $stptr (',GFloating'),
	key_unsigned = $stptr (',UNSIGNED'),
	key_null = $stptr ('');

    BIND
	tag_file_ctl = $fao_ctl (		!
		'SORT /REC:!SL /KEY:!SL,!SL!AZ !AZ ', 	! Keys and filetype
		'/SUPPRESS-ERROR:ALL', 		! No errors, please
		'/TEMPORARY:LOD$WORK: !AZ ', 	! Work area, input file
		'!-!AZ /RMS/ORG:SEQ/VAR!%^@');	! Output file
!    BIND
!	tag_file_ctl = $fao_ctl (		!
!		'SORT /REC:!SL /KEY:!SL,!SL!AZ !AZ ', 	! Keys and filetype
!		'/STATISTICS',			! Type stats for debugging
!		'/TEMPORARY:LOD$WORK: !AZ ', 	! Work area, input file
!		'!-!AZ /RMS/ORG:SEQ/VAR!%^@');	! Output file

    $tracei ('SORT_TAG_FILE');
    generate_tag_file_name (.kdb [kdb$h_reference]);
    !
    !	Set up common parameters
    !
    faoprm [5] = CH$PTR (fn_buf);		! Filename
    control = tag_file_ctl;			! See above

    !+
    !	Create for ourselves a SORT command
    !-

    CASE .kdb [kdb$v_datatype]			! Determine by datatype
    FROM xab$k_stg				! ...
    TO xab$k_bn4 OF 				! ...
	SET

	[xab$k_stg, xab$k_ebc, xab$k_six, xab$k_as8] :
	    BEGIN

	    LOCAL
		keybpw;				! Key bytes per word

	    keybpw = %BPVAL/.kdb [kdb$v_byte_size];	! How many per word
	    !
	    !	Record length is key size + length of RFA (in bytes)
	    !
	    faoprm [0] = .kdb [kdb$h_key_size_bytes] + .keybpw;	! Reclen
	    !
	    !	First byte must be 1 past the RFA
	    !
	    faoprm [1] = .keybpw + 1;		! Skip over RFA
	    faoprm [2] = .kdb [kdb$h_key_size_bytes];	! Key length
	    faoprm [3] = key_null;		! No additional info

	    SELECTONE .kdb [kdb$v_datatype] OF
		SET

		[xab$k_stg] :
		    faoprm [4] = file_ascii;	! ASCII file

		[xab$k_ebc] :
		    faoprm [4] = file_ebcdic;	! EBCDIC file

		[xab$k_six] :
		    faoprm [4] = file_sixbit;	! SIXBIT file

		[xab$k_as8] :
		    faoprm [4] = file_as8;	! Strange file
		TES;

	    END;

	[xab$k_pac] :
	    BEGIN
	    faoprm [0] = .kdb [kdb$h_key_size_bytes] + 4;	! Reclen
	    faoprm [1] = 5;			! Skip over RFA
	    faoprm [2] = (.kdb [kdb$h_key_size_bytes]*2) - 1;	! Key length
	    faoprm [3] = key_pac;		! Give more information
	    faoprm [4] = file_ebcdic;		! EBCDIC file
	    END;

	[xab$k_in4, xab$k_fl1, xab$k_bn4] :
	    BEGIN
	    faoprm [0] = 2;			! Two-word record
	    faoprm [1] = 2;			! Skip over RFA
	    faoprm [2] = 1;			! Key length

	    IF .kdb [kdb$v_datatype] EQL xab$k_bn4	!
	    THEN
		faoprm [3] = key_unsigned	! Unsigned key
	    ELSE
		faoprm [3] = key_signed;	! Signed keys

	    faoprm [4] = file_binary;		! Binary file
	    END;

	[xab$k_in8, xab$k_fl2, xab$k_gfl] :
	    BEGIN
	    faoprm [0] = 3;			! Three-word record
	    faoprm [1] = 2;			! Skip over RFA
	    faoprm [2] = 2;			! Key length

	    IF .kdb [kdb$v_datatype] EQL xab$k_gfl	!
	    THEN
		faoprm [3] = key_gfl		! G-floating key
	    ELSE
		faoprm [3] = key_signed;	! Use signed keys

	    faoprm [4] = file_binary;		! Binary file
	    END;
	TES;

    $faol (ctrstr = .control, outbuf = srtdsc, 	! Make the command
	outlen = srtlen, prmlst = faoprm);
!    psout (ch$ptr (srtbuf));
!    psout ($stptr (%char(13,10)));
    !
    !	Set up the SORT command descriptor
    !
    srtarg [0] = .lodsec or .srtdsc [str$a_pointer];	! Pointer to command
    srtarg [1] = .srtlen;			! Length of command

    IF NOT (srtsts = sort (srtarg))		! Sort the tag file
    THEN
	BEGIN
	RETURN $signal_error (			!
		control = '!/?SORT failed for key !SL!/', 	!
		p1 = .kdb [kdb$h_reference]);
	END
    ELSE
	BEGIN
	RETURN lod$_success;
	END;

    END;					! End of SORT_TAG_FILE
%SBTTL 'Routine GENERATE_TAG_FILE_NAME'
ROUTINE generate_tag_file_name (key_number) =
    BEGIN
    $tracei ('GENERATE_TAG_FILE_NAME');
    !
    !	Generate the file name
    !
    control = $fao_ctl ('LOD$WORK:LOD!SL.ID-!SL!%^@');
    faoprm [0] = .key_number;			! This key
    faoprm [1] = .pid<0, 18>;			! Unique identifier
    $faol (ctrstr = .control, outbuf = fn_dsc, prmlst = faoprm);
    $traceo ('GENERATE_TAG_FILE_NAME');
    RETURN lod$_success;
    END;					! End of GENERATE_TAG_FILE_NAME
%SBTTL 'Routine DO_SIDRS'
ROUTINE do_sidrs =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	data_bkt_hdr : REF $rms_bucket_header,
	new_record : REF $rms_sidr;

    $tracei ('DO_SIDRS');

    DO
	BEGIN
	!
	!   Allocate a bucket, if needed
	!

	IF .curbkt [0, bkt$a_address] EQL 0	! Empty?
	THEN
	    BEGIN
	    $trace ('Allocating data bucket');
	    do_data_bucket ();			! Allocate a data_bucket
	    END;

	data_bkt_hdr = .rmssec OR .curbkt [0, bkt$a_address];
	!
	!   Set pointers for this new record.  Notice that
	!   NXTREC will point at the location of the first
	!   RFA in the SIDR (it will be incremented as
	!   RFAs are appended to the record).
	!
	currec [0] = .nxtrec [0];		! Where new record goes
	nxtrec [0] = .nxtrec [0] + .sidrlen;	! Next here

	!+
	!   Build the record header.  This comprises the flags,
	!   ID, and size of the data.
	!-

	new_record = .currec [0];
	!
	!   Set the ID, and build the RFA at the same time.
	!   Also, bump the bucket's NEXT_ID.
	!
	new_record [sdr$h_id] = .data_bkt_hdr [bhd$h_next_id];
	data_bkt_hdr [bhd$h_next_id] = .data_bkt_hdr [bhd$h_next_id] + 1;
	!
	!   Set the length of the record (which for now
	!   is just the key) in the header.
	!
	new_record [sdr$h_size] = .kdb [kdb$h_key_size_words];
	!
	!   Move the key to the appropriate spot
	!
	$copy_words (.lodsec OR key_buffer, 	! From here
	    .currec [0] + sdr$k_bln, 		! To here
	    .kdb [kdb$h_key_size_words]);	! Length in words
	!
	!   Decrement the space remaining appropriately
	!   and update the bucket header as well
	!
	freespace [0] = .freespace [0] - .sidrlen;
	data_bkt_hdr [bhd$h_next_byte] = 	!
	.data_bkt_hdr [bhd$h_next_byte] + .sidrlen;
	!
	!   Add the RFA(s) to this record (more than
	!   one if dups exist and are allowed).
	!
	$trace ('Appending RFA(s) to SIDR');
	do_rfa ();

	!+
	!   If we have reached end of file or
	!   if we have filled this bucket,
	!   then make an index record for this bucket.
	!-

	IF .eof OR 				! End-of-file?
	    (.freespace [0] LSS (.sidrlen + rfa$k_bln))	! Bucket full?
	THEN
	    BEGIN
	    $trace ('Generating index record for SIDR bucket');
	    do_idr (1);				! Generate an index record
	    END;

	END
    UNTIL .eof EQL true;

    $traceo ('DO_SIDRS');
    RETURN 1;
    END;					! End of DO_SIDRS
%SBTTL 'Routine DO_RFA'
ROUTINE do_rfa =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    BIND
	new_record = .currec [0] : $rms_sidr,	! Current SIDR
	sdr_bucket = .rmssec OR 		!
	    .curbkt [0, bkt$a_address] : $rms_bucket_header;

    $tracei ('DO_RFA');

    DO
	BEGIN

	BIND
	    new_rfa = .nxtrec [0];		! For easy pointing

	new_rfa = .tag_record [tag$g_rfa];	! Move the RFA
	nxtrec [0] = .nxtrec [0] + rfa$k_bln;	! Bump pointer
	new_record [sdr$h_size] = 		! Increment record size
	.new_record [sdr$h_size] + rfa$k_bln;
	sdr_bucket [bhd$h_next_byte] = 		! Bump this too
	.sdr_bucket [bhd$h_next_byte] + rfa$k_bln;
	freespace [0] = .freespace [0] - rfa$k_bln;	! Decrement space left
	read_key_file (true);			! Get the next record

	IF .eof					!
	THEN
	    BEGIN
	    $trace ('Finished with RFAs because of EOF');
	    EXITLOOP;				! Quit on EOF
	    END;

	IF .freespace [0] LSS rfa$k_bln		! No more room?
	THEN
	    BEGIN
	    $trace ('Finished with RFAs because bucket is full');
	    EXITLOOP;				! Exit and make new SIDR
	    END;

	IF NOT .secondary_dup			! Loop for dups
	THEN
	    BEGIN
	    $trace ('Finished with RFAs because no dups exist');
	    EXITLOOP;
	    END;

	END
    WHILE 1;

    $traceo ('DO_RFA');
    RETURN lod$_success;			! Leave gracefully
    END;					! End of DO_RFA
%SBTTL 'Routine CREATE_TAG_FILE'
ROUTINE create_tag_file (key_number) =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN
    $tracei ('CREATE_TAG_FILE');
    !
    !	Allocate space for the FAB and RAB
    !
    tag_fab [.key_number] = getmem (fab$k_bln);
    tag_rab [.key_number] = getmem (rab$k_bln);
    !
    !	Create the file name for this tag file
    !
    generate_tag_file_name (.key_number);
    !
    !   Initialize the RAB and FAB
    !
    $fab_init (fab = .tag_fab [.key_number], 	!
	org = seq, rfm = var, fna = fn_buf, 	!
	rat = blk, mrs = 0, fac = <put, get>, 	!
	fop = sup, bsz = .kdb [kdb$v_byte_size]);	! Appropriate bytes
    $rab_init (rab = .tag_rab [.key_number], 	!
	fab = .tag_fab [.key_number], 		!
	rac = seq, ubf = tag_record, 		! UBF is for later input
	usz = tag$k_bln);			! USZ, too
    !
    !	Create the file and connect the RAB thereto
    !
    $create (fab = .tag_fab [.key_number], err = rmserr);
    $connect (rab = .tag_rab [.key_number], err = rmserr);
    tag_file_created [.key_number] = 1;
    $traceo ('CREATE_TAG_FILE');
    RETURN lod$_success;
    ;
    END;					! End of CREATE_TAG_FILE
%SBTTL 'Routine OPEN_KEY_FILE'
ROUTINE open_key_file (key_number) =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN
    $tracei ('OPEN_KEY_FILE');
    !
    !	Open the file name for this tag file
    !
    generate_tag_file_name (.key_number);
    !
    !   Initialize the RAB and FAB
    !
    $fab_init (fab = key_fab, fna = fn_buf, fac = get, fop = drj);	!
    $rab_init (rab = key_rab, fab = key_fab, 	!
	ubf = tag_record, usz = tag$k_bln);
    !
    !	Open the file and connect the RAB thereto
    !
    $open (fab = key_fab, err = rmserr);
    $connect (rab = key_rab, err = rmserr);
    eof = false;				! Reset EOF
    $traceo ('OPEN_KEY_FILE');
    RETURN lod$_success;
    END;					! End of OPEN_KEY_FILE
%SBTTL 'Routine READ_DATA'
ROUTINE read_data (order_checking) =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LITERAL
	record_ok = 1,				! Record is valid
	xcp_record = 2,				! Exception (illegal) record
	mrg_record = 3;				! Out-of-order record

    LOCAL
	status;					! Input status

    $tracei ('READ_DATA');

    WHILE 1 DO
	BEGIN

	IF .input_rtn EQL 0			! Use default routine?
	THEN
	    status = lodinp (in_rec)		! Yes - get a record
	ELSE
	    BEGIN				! No - call user back

	    BIND ROUTINE
		usrinp = .input_rtn;		! Set up routine

	    status = usrinp (in_rec);		! Make the call
	    END;

	IF NOT .status				! Something wrong?
	THEN
	    BEGIN
	    eof = true;				! Set end of file
	    $traceo ('READ_DATA (eof)');
	    RETURN 0;				! Return false
	    END;

	input_count = .input_count + 1;		! Bump counter
	in_rec [inp$h_words] = 			! Do calculations
	(.in_rec [inp$h_bytes] - 1)/.inpbpw + 1;

	IF .infab [fab$v_bsz] EQL .outfab [fab$v_bsz]	! Check byte size
	THEN
	    output_bytes = .in_rec [inp$h_bytes]	! Accurate to the byte
	ELSE
	    BEGIN

	    LOCAL
		extra_bits,			! Extra bits
		extra_inp_bytes,		! Spare input bytes
		extra_out_bytes;		! Spare output bytes

	    !
	    !   Figure the input bytes inside whole words
	    !
	    output_bytes = (.in_rec [inp$h_words] - 1)*.outbpw;
	    !
	    !   Now the input bytes left over
	    !
	    extra_inp_bytes = .in_rec [inp$h_bytes] MOD .inpbpw;
	    !
	    !   How many bits was that?
	    !
	    extra_bits = .extra_inp_bytes*.infab [fab$v_bsz];
	    !
	    !   How many output bytes does that take?
	    !
	    extra_out_bytes = (.extra_bits - 1)/.outfab [fab$v_bsz] + 1;
	    !
	    !   Done!
	    !
	    output_bytes = .output_bytes + .extra_out_bytes;
	    END;

	if .kdb[kdb$v_datatype] eql xab$k_stg  then   ! Ascii?
		BEGIN
		in_rec [inp$h_bytes] = .in_rec [inp$h_bytes] - 2;
		output_bytes = .output_bytes - 2;
		END;

	!+
	!   Now that we have the input and output lengths, check
	!   to be sure that the record is of legal length.
	!-

	status = record_ok;			! Everything's fine to start

	IF .outfab [fab$v_rfm] EQL fab$k_fix	! What record format?
	THEN
	    BEGIN				! Check fixed format

	    IF .output_bytes NEQ .outfab [fab$h_mrs]	! Wrong length
	    THEN
		BEGIN
		status = xcp_record;
		control = xcp$t_not_mrs;	! Set up message
		faoprm [2] = .output_bytes;	! What we had
		faoprm [3] = .outfab [fab$h_mrs];	! What it should be
		END;

	    END
	ELSE
	    BEGIN				! Check variable format

	    IF .outfab [fab$h_mrs] NEQ 0 AND 	! Check record size?
		.output_bytes GTR .outfab [fab$h_mrs]	! Record too big?
	    THEN
		BEGIN
		status = xcp_record;		! Illegal record
		control = xcp$t_too_big;	! Set up message
		faoprm [2] = .output_bytes;	! What we had
		faoprm [3] = .outfab [fab$h_mrs];	! What it should be
		END
	    ELSE

		IF .output_bytes LSS .minimum_data_size	! Too small?
		THEN
		    BEGIN
		    status = xcp_record;
		    control = xcp$t_too_small;	! Set up message
		    faoprm [2] = .output_bytes;	! What we had
		    faoprm [3] = .minimum_data_size;	! What it should be
		    END;

	    END;

	!+
	!   If we have not eliminated this record because of
	!   length problems, then test for out-of-order keys
	!   (unless such checks are prohibited, as on the
	!   first input).
	!-

	IF .order_checking			! Do we need to look at key?
	THEN
	    BEGIN

	    LOCAL
		comp_sts,			! Returned comparison value
		this_rec : $rms_record_descriptor;

	    this_rec [rec$a_user] = .lodsec OR key_buffer;
	    this_rec [rec$h_user_size] = .kdb [kdb$h_key_size_bytes];
	    comp_sts = $utl_ckeyku (udr = .in_rec [inp$a_data], 	!
		recdesc = .lodsec OR this_rec, error = utlerr);	!

	    IF .comp_sts EQL true		! Last key LEQ new key
	    THEN
		BEGIN				! New key GEQ old key

		IF NOT .this_rec [rec$v_less]	! New key EQL old key
		THEN

		    IF NOT .kdb [kdb$v_dup]	! Dups allowed?
		    THEN
			BEGIN
			status = xcp_record;	! No - illegal record
			control = xcp$t_illegal_dup;	! Set up message
			END;

		END
	    ELSE
		BEGIN				! Key out of order
		status = mrg_record;		! Output and merge later
		END;

	    END;				! End of order checking

	!
	!   Well, by now we know if we want to put this record
	!   in the file, to write it to the exception file, or
	!   to write it out and try to merge it later.
	!

	SELECTONE .status OF
	    SET

	    [record_ok] :
		!
		!   Update KEY_BUFFER, bump the counter,
		!   and exit this loop.
		!
		BEGIN
		$utl_movekey (keybuf = .lodsec OR key_buffer, 	! Key buffer
		    recptr = .in_rec [inp$a_data], 	! Input record
		    error = utlerr);		! ...
		loaded_count = .loaded_count + 1;	! Bump counter
		EXITLOOP;
		END;

	    [xcp_record] :
		do_xcp_rec ();			! Write XCP record

	    [mrg_record] :
		do_mrg_rec ();			! Write MRG record
	    TES;

	END;

    $traceo ('READ_DATA');
    RETURN 1;
    END;					! End of READ_DATA
%SBTTL 'Routine READ_KEY_FILE'
ROUTINE read_key_file (order_checking) =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
!	NONE.
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LITERAL
	record_ok = 1,				! Record is valid
	xcp_record = 2;				! Exception (illegal) record

    LOCAL
	comp_sts,				! Returned comparison value
	this_rec : $rms_record_descriptor,	! Argument to CKEYKK
	status;					! Input status

    $tracei ('READ_KEY_FILE');

    WHILE 1 DO
	BEGIN
	status = $get (rab = key_rab, err = rmserr);

	IF NOT .status				! Something wrong?
	THEN
	    BEGIN
	    eof = true;				! Set end of file
	    $traceo ('READ_KEY_FILE (eof)');
	    RETURN 0;				! Return false
	    END;

	!+
	!   If we have not eliminated this record because of
	!   length problems, then test for out-of-order keys
	!   (unless we shouldn't, as on the first input).
	!-

	IF .order_checking			! Check keys?
	THEN
	    BEGIN
	    !
	    !   THIS_REC describes the "search key", which is
	    !   the new record in the TAG_RECORD buffer.
	    !
	    this_rec [rec$a_user] = .lodsec OR tag_record [tag$t_key];
	    this_rec [rec$h_user_size] = .kdb [kdb$h_key_size_bytes];
	    !
	    !   Compare the search key against the value in
	    !   KEY_BUFFER, wherein lies the last key
	    !   read in.
	    !
	    comp_sts = $utl_ckeykk (keybuf = .lodsec OR key_buffer, 	!
		recdesc = .lodsec OR this_rec, error = utlerr);	!
	    END
	ELSE
	    comp_sts = false;			! Pretend new key is GTR

	!+
	!   If the status returned is TRUE, then the
	!   new key is less than or is equal to the
	!   old key.  "Less than" would be an error, and
	!   "equal to" is an error if duplicates are not
	!   allowed.
	!
	!   If the status returned is FALSE, then the new
	!   key is greater than the previous key, which is
	!   as it should be.
	!-

	IF .comp_sts EQL true			! Is all well?
	THEN
	    BEGIN				! New key is not greater

	    IF .this_rec [rec$v_less]		! Is new key a duplicate?
	    THEN
		BEGIN				! No - key out of order
		RETURN $signal_error (		! This is terrible
		    control = '!/?Out-of-order key in !J!/', !
		    p1 = .key_fab [fab$h_jfn]);
		END
	    ELSE
		BEGIN				! This IS a duplicate
		$trace ('New key EQL old one');

		IF .kdb [kdb$v_dup]		! Dups allowed?
		THEN
		    BEGIN
		    $trace ('...and duplicates ARE allowed');
		    secondary_dup = true;	! Make note: legal dup
		    END
		ELSE
		    BEGIN
		    $trace ('...but duplicates ARE NOT allowed');
		    secondary_dup = false;	! Forget it: illegal dup
		    status = xcp_record;	! No - illegal record
		    control = xcp$t_ill_sec_dup;	! Set up message
		    faoprm [1] = .kdb [kdb$h_reference];
		    END;

		END;

	    END
	ELSE
	    BEGIN				! Key is in right order
	    $trace ('New key GTR old one: all OK');
	    secondary_dup = false;		! Clear dups flag
	    END;

	!+
	!   Well, by now we know if we want to put this record
	!   in the file, to write it to the exception file, or
	!   to write it out and try to merge it later.
	!-

	SELECTONE .status OF
	    SET

	    [record_ok] :
		!
		!   Update KEY_BUFFER, bump the counter,
		!   and exit this loop.
		!
		BEGIN
		$trace ('Record OK');

		IF NOT .secondary_dup		! Do we have to update key?
		THEN
		    BEGIN
		    $trace ('Copying new key to key buffer');
		    $copy_words (		! Copy this key
			.lodsec OR tag_record [tag$t_key], 	! From here
			.lodsec OR key_buffer, 	! To here
			.kdb [kdb$h_key_size_words]);	! Length to move
		    END;

		EXITLOOP;
		END;

	    [xcp_record] :
		BEGIN
		$trace ('Record has a problem');
		sec_xcp_rec ();			! Write XCP record
		END;
	    TES;

	END;

    $traceo ('READ_KEY_FILE');
    RETURN 1;
    END;					! End of READ_KEY_FILE
%SBTTL 'Routine SEC_XCP_REC'
ROUTINE sec_xcp_rec =
    BEGIN

    LOCAL
	current_key,				! Save key here
	rd_packet : $rms_record_descriptor,	! Record descriptor packet
	xcp_bdesc : $rms_bucket_descriptor,
	xcp_bkt : $rms_bucket_header,
	xcp_rec : $rms_user_data_record;

    $tracei ('SEC_XCP_REC');
    !
    !	Find the record specified by the tag-file's RFA
    !
    current_key = .kdb [kdb$h_reference];	! Save current key
    kdb = .rmssec OR $utl_getkdb (key_of_reference = 0, 	!
		error = utlerr);
    rd_packet [rec$g_rfa] = .tag_record [tag$g_rfa];	! Set up RFA
    rd_packet [rec$a_record] = 0;		! Search whole bucket
    $utl_fbyrfa (				! Find the record
	recdesc = .lodsec OR rd_packet, 	! Record RFA
	bucket = .lodsec OR xcp_bdesc, 		! Bucket to hold it
	error = utlerr);			! ...
    kdb = .rmssec OR $utl_getkdb (key_of_reference = .current_key, 	!
		error = utlerr);
    xcp_rec = .rmssec OR .rd_packet [rec$a_record];	! Set pointer

    !+
    !	We now have a record which has at least one
    !	duplicate secondary key.  If it has not been
    !	deleted, then bump the XCP counter and
    !	decrement the Loaded counter.
    !	Write the data to the XCP file with an
    !	appropriate entry in the LIS file.
    !
    !	If it has been deleted already, don't do anything.
    !-

    IF NOT .xcp_rec [udr$v_deleted]		! Is record still valid?
    THEN
	BEGIN					! Yes - process appropriately
	$trace ('Record has not been deleted - delete it');
	xcp_count = .xcp_count + 1;		! Bump counter
	loaded_count = .loaded_count - 1;	! Decrement this counter

	!+
	!   How big a record are we writing?
	!-

	IF .outfab [fab$v_rfm] EQL fab$k_fix	! Fixed or variable
	THEN
	    xcp_rab [rab$h_rsz] = .outfab [fab$h_mrs]	! Size is MRS
	ELSE
	    xcp_rab [rab$h_rsz] = .xcp_rec [udr$h_size];	! From record

	xcp_rab [rab$a_rbf] = .xcp_rec + .udr_header_length;	! Point at it
	$put (rab = xcp_rab, err = rmserr);	! Write it out
	faoprm [0] = .xcp_count;		! Which XCP record
	$faol (ctrstr = .control, outbuf = lstdsc, 	! Write to LIS file
	    prmlst = faoprm, outlen = lstlen);	!
	lst_rab [rab$h_rsz] = .lstlen;		! Length of output
	lst_rab [rab$a_rbf] = lstbuf;		! Address of data
	$put (rab = lst_rab, err = rmserr);	! Write LIS item

	!+
	!   Delete the record and update the bucket.
	!-

	xcp_rec [udr$v_deleted] = 1;		! Delete record
	$utl_putbkt (update = 1, 		! Write it out
	    bucket = .lodsec OR xcp_bdesc, 	! ...
	    error = utlerr);			! ...
	END;

    $traceo ('SEC_XCP_REC');
    RETURN lod$_success;
    END;					! End of SEC_XCP_REC
%SBTTL 'Routine DO_XCP_REC'
ROUTINE do_xcp_rec =
    BEGIN
    $tracei ('DO_XCP_REC');
    !
    !	Bump the counter and write out the XCP record
    !
    xcp_count = .xcp_count + 1;
    xcp_rab [rab$h_rsz] = .output_bytes;
    xcp_rab [rab$a_rbf] = .in_rec [inp$a_data];
    $put (rab = xcp_rab, err = rmserr);
    faoprm [0] = .xcp_count;
    faoprm [1] = .input_count;			! Which record failed?
    $faol (ctrstr = .control, outbuf = lstdsc, 	!
	prmlst = faoprm, outlen = lstlen);
    lst_rab [rab$h_rsz] = .lstlen;		! Length of output
    lst_rab [rab$a_rbf] = lstbuf;		! Address of data
    $put (rab = lst_rab, err = rmserr);
    $traceo ('DO_XCP_REC');
    RETURN lod$_success;
    END;					! End of DO_XCP_REC
%SBTTL 'Routine DO_MRG_REC'
ROUTINE do_mrg_rec =
    BEGIN
    $tracei ('DO_MRG_REC');
    !
    !	Bump the counter and write out the MRG record
    !
    mrg_count = .mrg_count + 1;
    mrg_rab [rab$h_rsz] = .output_bytes;
    mrg_rab [rab$a_rbf] = .in_rec [inp$a_data];
    $put (rab = mrg_rab, err = rmserr);
    $traceo ('DO_MRG_REC');
    RETURN lod$_success;
    END;					! End of DO_MRG_REC
%SBTTL 'Routine LODINP'
ROUTINE lodinp (inrec : REF $lod_input_descriptor) =
    BEGIN
	$tracei ('LODINP');
    $get (rab = inrab, err = rmserr);

    IF .inrab [rab$h_sts] NEQ rms$_normal	! Not OK?
    THEN
	BEGIN
	RETURN 0;				! Return false
	END
    ELSE
	BEGIN					! Set up descriptor
	inrec [inp$a_data] = .inrab [rab$a_rbf];

	IF .inrab [rab$a_rbf] NEQ .inrab [rab$a_ubf]	! Our or RMS's buffers?
	THEN
	    inrec [inp$a_data] = .inrec [inp$a_data] OR .rmssec	! RMS's buffers
	ELSE
	    inrec [inp$a_data] = .inrec [inp$a_data] OR .lodsec;	! Ours

	inrec [inp$h_bytes] = .inrab [rab$h_rsz];
	$traceo ('LODINP');
	RETURN 1;				! Return true
	END;

    END;					! End of LODINP
%SBTTL 'RMSERR - signal an RMS error'
ROUTINE rmserr (jsys_code, 			! JSYS which bombed
    rms_block : REF BLOCK []

    FIELD
    (fab$r_fields, rab$r_fields), 		!
    rms_status) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	RMSERR is called when an RMS error occurs.  It has the
!	standard RMS error routine interface, which receives the
!	JSYS code, the block address, and the status code as
!	arguments.  If the status code is EOF, RMSERR returns a
!	0; otherwise, it prepares an FAO control string and
!	parameter list to describe the error.  It then SIGNALs an
!	error, and the LODLOD condition handler, LODHDL, catches
!	the signal, outputs the message, and (probably) unwinds,
!	after performing some cleanup.
!
! FORMAL PARAMETERS
!
!	JSYS_CODE	- the RMS JSYS or call which failed
!	RMS_BLOCK	- the RMS argument block given to the
!			  call; this is declared here with both
!			  FAB and RAB fields declared to provide
!			  a generalized RMS block, because the block
!			  may be either a FAB or a RAB.
!	RMS_STATUS	- error status; good for a quick check
!
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
!
!	Zero if EOF; no return expected otherwise
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    BIND
	jsys_msgs = UPLIT (			! Table of messages
	    $stptr ('opening'),			! $OPEN
	    $stptr ('closing'),			! $CLOSE,
	    $stptr ('reading record from'),	! $GET
	    $stptr ('writing record to'),	! $PUT
	    $stptr ('updating record in'),	! $UPDATE
	    $stptr ('deleting record from'),	! $DELETE
	    $stptr ('locating record in'),	! $FIND
	    $stptr ('truncating'),		! $TRUNCATE
	    $stptr ('connecting to'),		! $CONNECT
	    $stptr ('disconnecting from'),	! $DISCONNECT
	    $stptr ('creating'),		! $CREATE
	    $stptr ('setting debugging'),	! $DEBUG
	    $stptr ('releasing record in'),	! $RELEASE
	    $stptr ('flushing buffers of'),	! $FLUSH
	    $stptr ('enabling messages'),	! $MESSAGE
	    $stptr ('disabling messages'),	! $NOMESSAGE
	    $stptr ('displaying attributes of'),	! $DISPLAY
	    $stptr ('deleting the file'),	! $ERASE
	    $stptr ('freeing all records in'),	! $FREE
	    $stptr ('making a utility call')) : VECTOR [];

    BIND
	bugctl = $fao_ctl (			! Strange bug
		'!/?RMS JSYS !4OW returned error status !OW!/'),
	jfnctl = $fao_ctl (			! File error
		'!/?RMS error !OW (!OW) encountered when !AZ !J!/'),
	fnactl = $fao_ctl (			! File error
		'!/?RMS error !OW (!OW) encountered when !AZ !AZ!/'),
	nflctl = $fao_ctl (			! Non-file error
		'!/?RMS error !OW encountered when !AZ !/');

    LOCAL
	errfna,					! FNA of error FAB
	errjfn;					! JFN of error

    !+
    !	Don't let an EOF go any further.
    !-

    IF .rms_status EQL rms$_eof THEN RETURN 0;

    CASE .jsys_code				! What do we do?
    FROM rms$open_jsys TO rms$utlint_jsys OF
	SET

	[rms$debug_jsys, rms$message_jsys, rms$nomessage_jsys] :
	    BEGIN
	    errctl = nflctl;
	    errprm [0] = .rms_status;
	    errprm [1] = .jsys_msgs [.jsys_code - %O'1000'];
	    END;

	[INRANGE] :
	    BEGIN
	    errprm [0] = .rms_status;
	    errprm [1] = .rms_block [fab$h_stv];	! Pretend it's a FAB
	    errprm [2] = .jsys_msgs [.jsys_code - %O'1000'];

	    !+
	    !	Get the JFN
	    !-

	    IF .rms_block [fab$h_bid] EQL fab$k_bid	! This is a FAB
	    THEN
		BEGIN
		errfna = .rms_block [fab$a_fna];	! Get filename
		errjfn = .rms_block [fab$h_jfn];	! Get JFN easily
		END
	    ELSE
		BEGIN				! Get JFN with difficulty

		LOCAL
		    tmpfab : REF $fab_decl;

		tmpfab = .rms_block [rab$a_fab];	! Point at FAB
		errfna = .tmpfab [fab$a_fna];	! Get filename
		errjfn = .tmpfab [fab$h_jfn];	! Now get the JFN
		END;

	    !+
	    !	If we have no JFN, then use the FNA field.
	    !-

	    IF .errjfn EQL 0			! No JFN?
	    THEN
		BEGIN				! Use FNA instead
		errctl = fnactl;		! Set up control string
		errprm [3] = CH$PTR (.errfna);	! Point at ASCII filename
		END
	    ELSE
		BEGIN
		errctl = jfnctl;		! Use JFNS for filename
		errprm [3] = .errjfn;		! Pass the JFN
		END;

	    END;

	[OUTRANGE] :
	    BEGIN
	    errctl = bugctl;
	    errprm [0] = .jsys_code;
	    errprm [1] = .rms_status;
	    END;
	TES;

    RETURN SIGNAL (lod$_bug, .errctl, errprm);	! Signal an error
    END;					! End of RMSERR
%SBTTL 'UTLERR - signal a UTLINT error'
ROUTINE utlerr (jsys_code, 			! JSYS which bombed
    rms_block : REF BLOCK []

    FIELD
    (fab$r_fields, rab$r_fields), 		!
    rms_status) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	UTLERR is called when a $UTLINT error occurs.  It has the
!	standard RMS error routine interface, which receives the
!	JSYS code, the block address, and the status code as
!	arguments.  If the status code is EOF, UTLERR returns a
!	0; otherwise, it prepares an FAO control string and
!	parameter list to describe the error.  It then SIGNALs an
!	error, and the LODLOD condition handler, LODHDL, catches
!	the signal, outputs the message, and (probably) unwinds,
!	after performing some cleanup.
!
! FORMAL PARAMETERS
!
!	JSYS_CODE	- the RMS JSYS or call which failed: always $UTLINT
!	RMS_BLOCK	- the RMS argument block given to the
!			  call; this is declared here with both
!			  FAB and RAB fields declared to provide
!			  a generalized RMS block, because the block
!			  may be either a FAB or a RAB.
!	RMS_STATUS	- error status; good for a quick check
!
!
! IMPLICIT INPUTS
!
!	NONE.
!
! ROUTINE VALUE:
!
!	No return expected
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    BIND
	utlctl = $fao_ctl (			! Strange bug
		'!/?RMS utility interface error: status !OW!/');

    errctl = utlctl;				! Utility error
    errprm [0] = .rms_status;			! Status code
    RETURN SIGNAL (lod$_bug, .errctl, errprm);	! Signal an error
    END;					! End of UTLERR
%SBTTL 'LODHDL - condition handler'
ROUTINE lodhdl (sig : REF VECTOR, mech : REF VECTOR, enbl : REF VECTOR) =
    BEGIN

    BIND
	cond = sig [1],
	retval = mech [1],
	printmsg = .enbl [1],
	ctrl = sig [2],
	fprm = .sig [3] : VECTOR;

    IF .cond EQL ss$unw				! Unwinding?
    THEN
	RETURN 0;				! Resignal

    IF .printmsg				! Can we print anything
    THEN
	BEGIN
	!
	!   Format the message
	!
	$faol (ctrstr = .ctrl, prmlst = fprm, outbuf = errdsc, outlen = errlen);
	!
	!   Open the FAB, write the message, etc.
	!
	$open (fab = errfab);
	$connect (rab = errrab);
	errrab [rab$h_rsz] = .errlen;		! Length to output
	$put (rab = errrab);
	$close (fab = errfab);
	END;

    retval = lod$_bug;				! Return an error
    SETUNWIND ();				! Unwind
    RETURN 0;
    END;					! End of LODHDL
END						! End of Module LOADER

ELUDOM