*DECK FTNIF 
          IDENT  FILE$XX
          ENTRY  FILESQ,FILEWA
          SST 
          COMMENT   CRM FTN INTERFACE (FILESQ,FILEWA) 
          LDSET     LIB=BAMLIB     FOR ALL OTHER FTNIF ROUTINES 
          LIST   C,F,X
 FTNIF    TITLE  FILE$XX
*#
*1CD  FILE$XX 
*0D   PURPOSE 
*0        PROVIDE FTN INTERFACE FOR FILE MACRO - INITIALIZE FIT.
*0D   CALL
*0        CALL FILE$XX(FIT,KEYWORD1,VALUE1,...,KEYWORDN,VALUEN) 
*              WHERE XX=SQ,WA,IS,DA,AK. 
*0D   PARAMETERS
*0        FIT       FIT ADDRESS.
*         KEYWORD   FIT FIELD MNEMONIC. 
*         VALUE     VALUE TO BE STORED IN ASSOCIATED FIT FIELD. 
*0D   ACTION
*0        PUT FO IN X5, RJ TO SETFIT, AND RETURN TO USER. FOR IS, 
*         THE FIT ADDRESS MUST BE SAVED BEFORE THE RJ TO SETFIT 
*         AND THEN RELOADED UPON RETURN. THEN STORE PM=R. 
*0D   REGISTERS USED
*0        ALL 
*0D   OTHER CODE REQUIRED 
*0        MACROS-   NONE
*         PROGRAMS -  SETFIT, ER$PROC, STOREF 
*#
 FTNIF    TITLE  FILE$XX
 FILESQ   BSSZ   1
          SX5    #SQ# 
          RJ     =XSETFIT 
          EQ     FILESQ 
          SPACE  2
 FILEWA   BSSZ   1
          SX5    #WA# 
          RJ     =XSETFIT 
          EQ     FILEWA 
          END 
          IDENT  FILE$AA
          COMMENT   CRM FTN INTERFACE (FILEIS,FILEDA,FILEAK)
          LDSET     LIB=BAMLIB     FOR ALL OTHER FTNIF ROUTINES 
          SST 
          TITLE  FILE$AA
          ENTRY  FILEIS,FILEDA,FILEAK 
 TEMP     VFD    42/,18/=XCTRL$AA   FORCE LOAD  AMM STATIC CONTROLLER 
 FILEIS   BSSZ   1
          SA1    A1                SAVE FIT ADDRESS 
          SX5    #IS# 
          BX6    X1 
          SA6    TEMP 
          RJ     =XSETFIT 
          SA1    TEMP 
          STORE  X1,PM=R
          EQ     FILEIS 
          SPACE  2
 FILEDA   BSSZ   1
          SX5    #DA# 
          RJ     =XSETFIT 
          EQ     FILEDA 
          SPACE  2
 FILEAK   BSSZ   1
          SX5    #AK# 
          RJ     =XSETFIT 
          EQ     FILEAK 
          END 
          IDENT  FIT$COM
          SST 
          COMMENT   CRM FTN INTERFACE (IFETCH,STOREF,SETFIT)
          LIST      C,F,X 
          ENTRY  STOREF,IFETCH,SETFIT,SYM$SRH 
          EXT    ER$PROC,ER$1 
*#
* 
*     SAAMFTN:  FTN/CRM INTERFACE ROUTINES. 
*        SAAMFTN INTERFACES BETWEEN THE FORTRAN USER AND CRM, PROVIDING 
*        THE USER WITH THE CAPABILITY OF CALLING CRM DIRECTLY.
* 
*        THE FOLLOWING ROUTINES, USER CALLABLE, INTERFACE BETWEEN USER
*        AND CRM AS DESCRIBED IN THE FORTRAN REFERENCE MANUAL:  
*             OPN$CLS   ( OPENM, CLOSEM ) 
*             GET 
*             PUT 
*             REPLC 
*             DLTE
*             GETN
*             SEEKF 
*             SKIP
*             REWND 
*             GETP
*             PUTP
*             SQANDWA   (WEOR, WTMK, ENDFILE, CHECK)
*             RMOPNX    (USED FOR MIP, AND DOCUMENTED ACCORDINGLY)
* 
* 
*#
*#
* 
* 
*     FIT$COM : 
*         FIT$COM CONTAINS THE FOLLOWING ROUTINES : 
*             STOREF    (USER CALLABLE) 
*             IFETCH    (USER CALLABLE) 
*             SEARCH    (INTERNALLY CALLED) 
*             SYM$SRH   ( INTERNALLY AND EXTERNALLY CALLED )
*             SYMSRCH1  (INTERNALLY CALLED) 
* 
* 
*#
 SYMB     MACRO  A
          VFD    18/0L_A,12/#_A_# 
          ENDM
*#
* 
* 
*     PROCEDURE:  STOREF
*         STORES VALUES INTO FIT FIELDS AS DOCUMENTED IN THE FORTRAN
*         REFERENCE MANUAL.  CALLS SEARCH, SYMSRCH1, AND/OR ER$PROC.
* 
* 
*#
 FMTERR   BSS    0
          SB2    1                 FORMAT ERROR 
          RJ     ER$PROC
 STFEXIT  BSS    0
          SA5    =SAVA0 
          SA0    X5 
          ENTRY     RM$IST
 RM$IST   BSS 
 STOREF   BSSZ   1
          SB6       STFEXIT 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB7    3                 ERROR CODE FOR IFETCH ERROR
          MX5       0              PLST$RM MASK REGISTER
          RJ        =XRM$ILD       SET UP REGISTERS 
          MX4    6
          SB3    B0                SHIFT COUNT
          GT     B4,B1,PAROK       IF PARAMETER FORMAT IS OK
          SB2    B1                FORMAT ERROR 
          RJ     ER$PROC
          EQ     STFEXIT
PAROK     BSS    0
          SA1       =XPL$FWA
          SA5       WSA.KA         CHECK FOR WSA OR KA SPECIFICATION
          MX4       18
          BX4       X2*X4 
          IX4       X4-X5          DETERMINE IF WSA 
          ZR        X4,GOT.IT 
          SA5       A5+B1 
          MX4       12
          BX4       X2*X4 
          IX4       X4-X5          DETERMINE IF KA
 .BETA    IFNE      #BETA#,0
          ZR        X4,GOT.IT.
 .BETA    ELSE
          ZR        X4,GOT.IT 
 .BETA    ENDIF 
 LOOP     BSS       0 
          SA5       A5+B1 
          ZR        X5,NO.GOT 
          MX4       18
          BX4       X2*X4 
          IX4       X4-X5          CHECK IF ADDRESS PARAM 
 .BETA    IFNE      #BETA#,0
          ZR        X4,GOT.IT.
 .BETA    ELSE
          ZR        X4,GOT.IT 
 .BETA    ENDIF 
          EQ        LOOP
 .BETA    IFNE      #BETA#,0
 GOT.IT.  BSS       0              CHECK IF ILLEGAL LCM ADDRESSING
          SA4       =XSAV$ADR      PICK UP ADDRESS SAVED BY RM$ILD
          ZR        X1,NOT.CHAR 
          BX4       X1             PICK UP ADDRESS SAVED BY PLST$RM 
 NOT.CHAR BSS       0 
          LX4       59-21 
          PL        X4,GOT.IT 
          SB6       STFEXIT 
          CRMEP     ES=557B,FNF=1,EES=0 
 .BETA    ENDIF 
 GOT.IT   BSS       0 
          ZR        X1,NO.GOT      THE PARAM NOT CHARACTER TYPE 
          SA3       =XPL$BCP
          ZR        X3,PARAM.OK 
          SB6       STFEXIT 
          CRMEP     ES=321B,FNF=1,EES=0   FATAL ERROR ABORT 
 PARAM.OK BSS       0 
          SA3       X1             PARAM VALUE IS ADDRESS IN PL$FWA 
 NO.GOT   BSS       0 
          RJ        SEARCH         WIPES B6 
          EQ   B3,STFEXIT 
          SX6    B1 
          BX3    X3*X6
          NZ     X3,FITERR         ILLEGAL STORE ACCESS 
          SX0    B6-2              TEST IF XN OF MFN
 .BETA    IFNE      #BETA#,0
          SX2       A3
          SA3       =XPL$FWA       PICK UP ADDRESS SAVED BY PLST$RM 
          ZR        X3,NON.CHAR 
          SX3       X2
          EQ        CHAR.DAT
 NON.CHAR BSS       0 
          SA3       =XSAV$ADR      PICK UP ADDRESS SAVED BY RM$ILD
 CHAR.DAT BSS       0 
          BX2       X3             IN CASE THE ADDRESS IS NEEDED
 .BETA    ELSE
          SX2       A3             IN CASE THE ADDRESS IS NEEDED
 .BETA    ENDIF 
          SA3    A2                PUT FIT MNEUMONIC INTO X3
          MX7       18
          BX6       X3*X7 
          LX6       18
          SX7       3RCPA          IF FIT FIELD IS CPA
          BX7       X6-X7 
          NZ        X7,NOTCPA 
          NZ        B5,VALUE
          SA3       X2             LOAD VALUE OF PARAMETER
          SB5       X3
          LT        B5,B1,USEADR   IF LESS THAN 1 
          SB5       B5-77B
          GT        B5,B0,USEADR   IF GREATER THAN 77B
          SA2       X2             LOAD VALUE OF PARAMETER
 USEADR   BSS       0 
          SB5       B0             RESET B5 
VALUE     EQ        AA             X2 CONTAINS VALUE
NOTCPA    BSS       0 
          EQ     B5,AA       IF VALUE IS AN ADDRESS, SKIP TO AA 
          SA2    X2                LOAD VALUE OF PARAMETER
          ZR     X0,XN             IF XN, LFN, OR MFN, STRIP BLANKS 
          NZ     B6,NOTBLNK        IF NOT SYMBOLIC
 XN       BSS       0 
          SB5       B0
          BX6       X2
          AX6       54
          ZR     X6,FMTERR         NUMBER ILLEGAL FOR SYMBOLIC FIELD
          MX4       6 
BLNK      LX4       6              CHECK NEXT CHARACTER 
          BX6       X4*X2          ISOLATE CHARACTER
          AX6       B5             CHARACTER RIGTH JUSTIFIED
          SX6       X6-55B
          NZ        X6,NOTBLNK     END TRAILING BLANKS
          SB5       B5+6           INCREASE SHIFT COUNT 
          BX2       -X4*X2         REPLACE BLANK WITH ZERO
          EQ        BLNK           NEXT CHARACTER 
NOTBLNK   SB5       B1
          NZ        X0,NOTXN    IF NOT XN,LFN, OR MFN 
          AX2       X2,B4     EITHER 18 OR 24 BITS
 NOTXN    NE     B6,AA       JUMP IF NOT SYMBOLIC 
          RJ     SYMSRCH1 
          EQ   B5,STFEXIT 
 AA       SB6    60 
          EQ     B6,B3,FL60        JUMP IF FIELD IS 60 BITS 
          SA3    A0+B2             LOAD FIT WORD WITH FIELD 
          NE     B1,B3,FLOTHER     JUMP IF NOT 1 BIT FIELD
          SX6    B1                SET BIT FOR 1-BIT FIELD
          LX6    B4,X6             SHIFT BIT TO FIELD POSITION
          SA4    A1+B1       REVERSE BITS IF PROCESSING-MODE. 
          SA4    X4 
          AX4    48 
          SX4    X4-2RPM
+         NZ     X4,*+1 
          SX0    B1 
          BX2    X0-X2             CHANGE 1 TO 0 OR 0 TO 1
          NZ     X2,AAA 
          PL     X2,BB             0 = +0 
 AAA      BSS    0                 1 " +0 
          BX6    X6+X3             TURN BIT ON
          SA6    A3 
          EQ     STFEXIT
 BB       BX6    -X6*X3            TURN BIT OFF 
          SA6    A3 
          EQ     STFEXIT
 FL60     BX6    X2 
          SA6    X1+B2             STORE A 60 BIT FIELD 
          EQ     STFEXIT
 FLOTHER  MX0    1
          SB5    B3-B1
          AX0    B5,X0             FORM MASK FOR FIELD
          LX0    B3,X0             SHIFT MASK TO BIT 0
          LX2    B4,X2             SHIFT VALUE TO FIELD POSITION
          LX0    B4,X0
          BX6    -X0*X3            CLEAN FIELD
          BX2    X0*X2
          BX6    X2+X6             AND IN NEW VALUE 
          SA6    A3                STORE WORD INTO FIT
          EQ     STFEXIT
 WSA.KA   DATA      3LWSA          NEEDED TO CORRECT FTN5 APLIST
          DATA      2LKA
          DATA      3LPKA 
          DATA      3LFWB 
          DATA      3LDCT 
          DATA      3LCDT 
          DATA      0 
* 
*#
* 
* 
*     PROCEDURE:  IFETCH
*         THIS ROUTINE WILL SEARCH THE FIT FOR A GIVEN FIT MNEUMONIC
*         AND RETURN THE ASSOCIATED VALUE, AS DOCUMENTED IN THE 
*         FORTRAN REFERENCE MANUAL. 
* 
* 
*#
 SUBR     BSSZ      1 
 IFHEXIT  BSS    0
          SA5       SUBR
          PL        X5,FUNC        IF CALLED WITH 2 PARAMETERS
          SA6       X5             STORE RESULT IN 3RD PARAMETER
 FUNC     BSS       0 
          SA5    =SAVA0 
          SA0    X5 
          ENTRY     RM$IFE
 RM$IFE   BSS 
 IFETCH   BSSZ   1
          SB6       FUNC
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB7    B1+B1             ERROR CODE FOR IFETCH
          SX5       10000B         PLST$RM MASK REGISTER
          RJ        =XRM$ILD       SET UP REGISTERS 
          GT     B4,B0,FORMATOK    IF CALLING FORMAT WAS OK 
          SB2    B1                ERROR CODE FOR FORMAT ERROR
          RJ     ER$PROC
          EQ     IFHEXIT
FORMATOK  BSS    0
          SX6       B4             PICK UP PARAMETER COUNT
          LX6       59-1           SET BIT 59 IF 3 PARAMETERS 
          SX3       A3             PICK UP ADDRESS OF 3RD PARAMETER 
          BX6       X6+X3          PUT ADDRESS IN X6
          SA6       SUBR           SAVE FOR IFHEXIT 
          SB2    18 
          SX6    A0 
          LX3    B2,X2
          SX7    X3-3RFET 
          ZR     X7,IFHEXIT 
          RJ        SEARCH         WIPES B6 
          EQ   B3,IFHEXIT 
          SA2    A0+B2             GET FIT WORD 
          EQ     B3,B1,ONEBIT      JUMP IF 1 BIT FIELD
          SB2    60 
          EQ     B3,B2,SIXTY       JUMP IF 60 BIT FIELD 
          SB4    B2-B4             B4=60-BIT POSITION 
          SB6    B6-2              CHECK FOR FILE NAME (B6=2) 
          LX2    B4,X2             SHIFT FIELD TO BIT 0 
          MX0    1
          SB3    B2-B3
          SB4    B3-B1
          AX0    B4,X0             FORM MASK FOR FIELD
          BX2    -X0*X2            CLEAN GARBAGE FROM WORD
          NE     B6,B0,SIXTY       JUMP IF NOT FILE NAME (LFN,MFN,XN) 
          LX2    B3,X2               ELSE LEFT-JUST FILE NAME 
 SIXTY    BX6    X2 
          EQ     IFHEXIT
 ONEBIT   SB5    59 
          SB4    B5-B4             B4=59-BIT POSITION 
          LX6    B4,X2             SHIFT BIT TO POSITION 59 
          EQ     IFHEXIT
*#
* 
* 
*     PROCEDURE:  SEARCH
*         GIVEN A FIT MNEMONIC, THIS ROUTINE WILL SEARCH THE FIT TABLE
*         FOR A MATCH.  IF FOUND, INFORMATION ABOUT THAT FIELD IS 
*         RETURNED. 
*             A- INPUT. 
*                X2=FIT MNEMONIC
*             B- OUTPUT 
*                B2=FIT WORD CONTAINING FIELD 
*                B3=LENGTH OF FIELD, SET TO ZERO IF NO MATCH FOUND
*                B4=BEGINNING BIT POSITION OF FIELD (59-0)
*                B5=0 IF FIELD CONTAINS AN ADDRESS
*                B6=0 IF THE FIELD VALUE IS SUPPLIED SYMBOLLICALLY
* 
* 
*         A BINARY SEARCH IS USED TO SEARCH A TABLE FOR MATCHING FIT
*       FIELDS.  UPON ENTRY INTO THE SEARCH ROUTINE, X2 CONTAINS THE
*       SYMBOL TO BE FOUND, AND X5 CONTAINS A MASK OF THE UPPER 30 BITS.
*       THE SCHEME USED IS AS FOLLOWS:  
*             1. INITIALIZE HIGH AND LOW
*             2. IF HIGH=LOW THEN GENERATE ERROR
*             3. POSITION=(HIGH+LOW)/2
*             4. FETCH SYMBOL AT CURRENT TABLE POSITION (PUT INTO X4) 
*             5. ISOLATE SYMBOL IN WORD AT CURRENT TABLE POSITION 
*             6. IF SYMBOLS MATCH, GO TO 12 
*             7. IF SYMBOL IN WORD SMALLER, GO TO 10
*             8. HIGH=CURRENT 
*             9. GO TO 2
*            10. LOW=CURRENT
*            11. GO TO 2
*            12. SET UP REGISTERS WITH MATCHING SYMBOL
* 
* 
*         REGISTER USAGE: 
*            X0=LOW 
*            X3=HIGH
*            X4=CURRENT ENTRY IN TABLE
*            X5=A THIRTY-BIT MASK 
*            (X1 MUST BE PRESERVED) 
* 
* 
*#
FILL      DATA      10H 
CHCOUNT   DATA      40404040404040404040B 
SEARCH    BSSZ      1 
          MX5       30
          BX3       X2
          LX3       30D            FIT FIELD MNEUMONIC LENGTH RESTRICTED
          PL        X3,NOSTRIP
          SA1       FILL           CREATE MASK
          SX7       B1
          BX3       X2-X1 
          IX7       X3-X7 
          BX7       -X3*X7
          SA1       A1+B1          ADJUST MASK LENGTH 
          BX7       X7*X1 
          BX1       X7
          LX7       55D 
          IX3       X1-X7 
          BX1       X1+X3 
          BX2       -X1*X2         APPLY MASK 
NOSTRIP   SX3       ENDTAB         HIGH 
          SX0    TABLE             LOW
BINLEWP   IX6    X3-X0
          ZR     X6,FITERR         IF HIGH=LOW THEN FITERR
          IX7    X3+X0
          AX7    1                 CURRENT=(HIGH+LOW)/2 
          SA4    X7                LOAD CURRENT ENTRY IN TABLE
          BX6    X5*X4             ISOLATE SYMBOL PART OF CURRENT WORD
          IX6    X6-X2             COMPARE SYMBOLS
          ZR     X6,EURIKA         MATCH FOUND
          NG     X6,BIGGER         TABLE VALUE TOO SMALL
          SX3    A4                HIGH=CURRENT 
          EQ     BINLEWP
BIGGER    SX0    A4+B1             LOW=CURRENT (ADD 1 TO INSURE ROUNDUP)
          EQ     BINLEWP
FITERR    BSS    0                 JUMP HERE IF UNDEFINED SYMBOL
          SB2    2                 ERROR-UNDEFINED SYMBOL 
          RJ     ER$PROC
          SB3    B0                B3=0 INDICATES ERROR OCCURRED
          MX3    0                 AVOID LOOP ON ILLEGAL ACCESS 
          EQ     SEARCH 
*   A MATCH HAS BEEN FOUND. EXTRACT THE FIELD INFORMATION 
*   FROM THE TABLE ENTRY AND STORE IN OUTPUT REGISTERS. 
EURIKA    BSS    0                 JUMP HERE IF MATCH FOUND 
          MX0    57 
          BX5    -X0*X4 
          SB6    X5 
          AX4    3
          BX3    -X0*X4 
          MX0    54 
          AX4    3
          BX5    -X0*X4 
          SB5    X5 
          AX4    6
          BX5    -X0*X4 
          SB4    X5 
          AX4    6
          BX5    -X0*X4 
          SB3    X5 
          AX4    6
          BX5    -X0*X4 
          SB2    X5 
          EQ     SEARCH 
*#
* 
* 
*     PROCEDURE:  SYMSRCH1
*         THIS MODULE WILL DETERMINE IF CONCATENATION IS NECESSARY IN 
*         ORDER TO MAKE A SYMBOL UNIQUE.  EXAMPLE:  FOR EO=T, T=0.  FOR 
*         RT=T, T=5.  TO ACHIEVE THIS RESULT A T IS CONCATENATED ONTO 
*         ALL SYMBOLS ASSOCIATED WITH THE RT FIT FIELD. 
*             A- INPUT
*                X2=SYMBOL
*                X3=FIT MNEUMONIC ASSOCIATED WITH SYMBOL
*                B1=1 
*             B- OUTPUT 
*                X2=VALUE OF SYMBOL 
*                B5=0 IF NO MATCH FOUND 
* 
* 
*#
 SYMSRCH1 BSSZ   1
          SA4    FILL           CREATE MASK 
          SX6    B1 
          BX4    X3-X4
          IX6    X4-X6
          BX6    -X4*X6 
          SA4    A4+B1
          BX6    X6*X4
          BX1    X6 
          LX6    55D
          IX4    X1-X6
          BX1    X1+X4
          BX3    -X1*X3         A 
          SA4    =2LLT                                                  0006   5
          IX0    X3-X4             CHECK IF LT SPECIFIED                0006   6
          NZ     X0,NOLT                                                0006   7
          SX6    B1                IF SPECIFIED SET FLAG                0006   8
          SA6    LTSPC                                                  0006   9
 NOLT     BSS    0                                                      0006  10
          SA4    KT 
          IX0    X3-X4
          NZ     X0,XRT            JUMP IF NOT KT FIELD 
          AX4    6
          BX2    X2+X4             CONCATENATE KT ONTO SYMBOL 
          EQ     XAA
 XRT      SA4    RT 
          IX0    X3-X4
          ZR     X0,CONCAT         JUMP IF RT FIELD 
          SA4    BT 
          IX0    X3-X4
          NZ     X0,ULP            JUMP IF NOT BT FIELD 
 CONCAT   SA4    T
          BX2    X2+X4             CONCATENATE T ONTO SYMBOL
          EQ     XAA
 ULP      SA4    XULP 
          IX0    X3-X4
          NZ     X0,XAA            JUMP IF NOT ULP FIELD
          SA4    U
          IX0    X2-X4
          NZ     X0,XAA            JUMP IF SYMBOL IS NOT A U
          SB5    4
          SX2    B5                SET VALUE OF U TO 4
          EQ     SYMSRCH1 
 XAA      BSS    0
          RJ     SYM$SRH
          EQ     SYMSRCH1 
 KT       DATA   2LKT 
 RT       DATA   2LRT 
 BT       DATA   2LBT 
 T        VFD    6/0,54/1LT 
 XULP     DATA   3LULP
 U        DATA   1LU
 LTSPC                             FLAG FOR LABEL TYPE                  0006  12
*#
* 
* 
*     PROCEDURE :  SYM$SRH
*         GIVEN A SYMBOL, THIS ROUTINE WILL SEARCH A SYMBOL TABLE FOR 
*         A MATCH.  IF FOUND, THE VALUE OF THE SYMBOL IS RETURNED.
*             A- INPUT
*                X2=SYMBOL
*             B- OUTPUT 
*                X2=VALUE OF SYMBOL 
*                B5=0 IF NO MATCH WAS FOUND 
* 
* 
*#
 SYM$SRH  BSSZ   1
  
  
  
*#
* 
* 
* 
*         EACH WORD IN THE SYMBOL TABLE HAS TWO ENTRIES, AS FOLLOWS:  
*                  59        41        29        11        0
*                  *****************************************
*                  *         *         *         *         *
*                  *         *         *         *         *
*                  * SYMBOL1 *  VALUE1 * SYMBOL2 * VALUE2  *
*                  *         *         *         *         *
*                  *         *         *         *         *
*                  *****************************************
* 
* 
*            A BINARY SEARCH IS USED TO FIND A MATCHING SYMBOL FOR A
*         PASSED PARAMETER.  THE CORRESPONDING VALUE IS RETURNED. 
* 
*         INPUT 
*            X2 - PARAMETER, LEFT JUSTIFIED 
*         OUTPUT
*            X2 - VALUE ASSOCIATED WITH PARAMETER 
*            B5 - 0 IF SYMBOL IS UNDEFINED
* 
* 
*         SEARCH SCHEME REGISTER USAGE: 
*            X0=LOW 
*            X7=HIGH
*            X6=MASK OF UPPER 45 BITS 
*            (X1 MUST BE PRESERVED) 
* 
*         ALGORITHM EMPLOYED: 
*             1. INTIALIZE HIGH AND LOW 
*             2. IF HIGH=LOW THEN GENERATE ERROR
*             3. POSITION=(HIGH+LOW)/2
*             4. FETCH SYMBOL AT CURRENT TABLE POSITION (PUT INTO X4) 
*             5. IF UPPER SYMBOL OF X4 EQUALS THAT IN X2, GO TO 12
*             6. IF UPPER SYMBOL OF X4 GREATER THAN X2, GO TO 10
*             7. IF LOWER SYMBOL IN X4 EQUALS THAT IN X2, GO TO 12
*             8. LOW=CURRENT
*             9. GO TO 2
*            10. HIGH=CURRENT 
*            11. GO TO 2
*            12. PUT VALUE ASSOCIATED WITH SYMBOL INTO X2 
* 
*         NOTE STEP 7.  IF THE DESIRED SYMBOL IS GREATER THAN THE SYMBOL
*          AT THE CURRENT TABLE POSITION, WE MUST ALSO CHECK THE SYMBOL 
*          IN THE LOWER HALF, SINCE WE CANNOT GET BACK TO THIS
*          WORD AGAIN.
* 
* 
* 
*#
          MX6    0                 NO MASK
          BX7    X2 
          LX7    12                LOOK AT THIRD CHARACTER FIRST
          PL     X7,MASK           IF CHARACTER IS NOT A BLANK
          MX6    6                 AT LEAST SIX BIT MASK NEEDED 
          LX7    54                LOOK AT SECOND CHARACTER 
          LX6    48                SHIFT MASK TO PROPER POSITION
          PL     X7,MASK           IF CHARACTER NOT A BLANK 
          MX6    12                ESTABLISH MASK 
          LX6    54                SHIFT MASK TO PROPER POSITION
MASK      BX2    -X6*X2            THESE STEPS ALLOW BLANK FILLED PARAMS
          LX2    18                SHIFT DESIRED SYMBOL TO RIGHT JUSTIFY
          MX6    42 
          SX7    ENDSYMT           X7=HIGH
          SX0    SYMTAB            X0=LOW 
          BX2    -X6*X2 
          SB5    B1                ASSUME MATCH WILL BE FOUND 
BINLOOP   IX3    X7-X0
          ZR     X3,ERROR          IF HIGH=LOW, THEN ERROR
          IX3    X7+X0
          AX3    1                 CURRENT=(HIGH+LOW)/2 
          SA4    X3                LOAD ENTRY AT CURRENT POSITION 
          LX4    18 
          BX3    -X6*X4 
          IX3    X3-X2             COMPARISON OF SYMBOLS
          ZR     X3,FOUND          SYMBOLS ARE EQUAL
          PL     X3,TOOBIG         DESIRED SYMBOL EARLIER IN TABLE
          LX4    30                NOW LOOK AT OTHER SYMBOL IN WORD 
          BX3    -X6*X4 
          IX3    X3-X2             COMPARISON OF SYMBOLS
          ZR     X3,FOUND          SYMBOLS ARE EQUAL
          SX0    A4+B1             LOW=CURRENT (ADD 1 TO INSURE ROUNDUP)
          EQ     BINLOOP
TOOBIG    SX7    A4                HIGH=CURRENT 
          EQ     BINLOOP
FOUND     LX4    12 
          MX6    48 
          BX2    -X6*X4            PUT CORRESPONDING VALUE IN X2
          EQ     SYM$SRH           RETURN 
 ERROR    BSS       0 
          SB2       B1+B1          INDICATES UNDEFINED SYMBOL 
          LX2       42             LEFT JUSTIFY SYMBOL
          RJ     ER$PROC
          SB5    0                 INDICATES NO MATCH FOUND 
          EQ     SYM$SRH           RETURN 
* 
* 
* 
 FORMER   SB2    B1                B2=1 INDICATES FORMAT ERROR
          RJ     ER$PROC
 XOUT     SX6    B0 
          SA6    ER$1 
          SA3    LTSPC             CHECK IF LABEL TYPE WAS SPECIFIED    0006  14
          SA1    PARALIST          GET FIT ADDRESS                      0006  16
          NZ     X3,GENFET
          STORE  X1,LT=UL          STORE DEFAULT VALUE FOR LT           0006  17
GENFET    SA3    X1                ADD COMPLETE BIT TO LFN
          SX6    B1 
          IX6    X3+X6
          SA6    A3 
          FETCH  X1,FWB,X2,,3      SET FIRST,IN,OUT,LIMIT 
          SX6    X1+#FTL#            DUMMY VALUES TO AVOID BUFFER 
          SX7    X1+#FTL#+2          ARG ERRORS AT OPEN TIME
          ZR     X2,SETPTRS 
          FETCH  X1,BFS,X5,,3 
          ZR     X5,SETPTRS 
          SX6    X2                USE USER-SPECIFIED VALUES
          IX7    X2+X5
SETPTRS   SA6    X1+2              IN 
          SA6    X1+3              OUT
          SA7    A6+B1             LIMIT
          BX3    X6                SAVE FWB 
          FETCH  X1,ASCII,X5
          SX6    23B               EP,XL,XP BITS
          SX7    #MNF#             FIT SIZE - 5 
          LX5       2 
          BX6    X5+X6
          LX6    22 
          BX6    X6+X7
          LX6    18 
          BX6    X6+X3
          SA6    X1+1              WORD 1 OF FET (EP,MUF,XL,XP,LEN,FIRST
          SX7    X1+8D             POINTER TO FET EXTENSION 
          SX6    B1 
          LX7    30 
          SA7    X1+6 
          SA6    X1+8D             FIRST WORD OF FET EXTENSION
          FETCH     X1,RT,X5       TEST RECORD TYPE FOR 
          SX5       X5-#RT#        RECORD MARK TYPE 
          NZ        X5,SETFIT 
          FETCH     X1,RMK,X5      TEST IF RMK IS ALREADY SET 
          NZ        X5,SETFIT 
          SX5       62B            IF NOT, SET RMK=62B
          STORE     X1,RMK=X5 
 SETFIT   BSSZ   1
          SB1    1
          SX6    B1 
          SA6    ER$1              ER$1=1 INDICATES SETFIT IF ERROR 
          SX7    B0                                                     0006  21
          SA7    LTSPC             CLEAN LT FLAG                        0006  22
          SA1    A1                X1=FIT ADDRESS 
          NZ     X1,BOK 
          SB2    B0                CODE FOR NO FIT ADDRESS
          RJ     ER$PROC
          EQ     XOUT 
BOK       SB2    34                ZERO 35 WORD FIT/FET 
          SX6    B0 
 LOOP5    SA6    X1+B2             STORE A ZERO WORD
          SB2    B2-B1             DECREMENT COUNTER
          GE     B2,LOOP5 
          SX6       X5-#SQ# 
          NZ        X6,NOPC 
          STORE     X1,PC=76B,2,6,7 DEFAULT PC
 NOPC     BSS       0 
          STORE     X1,IC=CSET,2,6,7  DEFAULT INTERNAL CODE 
          STORE     X1,ORG=NEW,2,6,7
          SX6    X5-#DA#
          NZ     X6,STORE.FO
          STORE  X1,EMK=YES,2,6,7 
 STORE.FO STORE  X1,FO=X5 
          SX6    X1 
          SA6    PARALIST          STORE FIT ADDRESS IN DUMMY LIST
          SA1    A1+B1
 LOOP3    ZR     X1,XOUT           EXIT IF END OF PARAMETER LIST
          SA3    A1+B1
          ZR     X3,FORMER         EXIT,FORMAT ERROR
          BX6    X1 
          SA6    B1+PARALIST       STORE PARAMETERS IN DUMMY LIST 
          BX6    X3 
          SA6    A6+B1
          SX6    A1 
          SA6    TEMP              STORE PARAMETER LIST POINTER 
          SA1    PARALIST          A1=ADDRESS OF DUMMY LIST 
          RJ     STOREF 
          SA2    TEMP 
          SA1    X2+2              INCREMENT POINTER FOR NEXT PAIR
          EQ     LOOP3
 TEMP     BSSZ   1
 SYMTAB   BSS    0
          SYMB   A
          SYMB   AD 
          SYMB   AK 
          SYMB   AKT
          SYMB   ANY
          VFD       18/0LASC,12/#ASCII# 
          SYMB      AS6 
          SYMB      AS8 
          SYMB      BCD 
          SYMB   BOF
          SYMB   BOI
          SYMB   BOV
          SYMB   BT 
          SYMB   CHK
          SYMB   CRT
          SYMB   CT 
          SYMB   D
          SYMB   DA 
          SYMB   DD 
          SYMB      DET 
          SYMB      DIS 
          SYMB   DR 
          SYMB   DT 
          SYMB      D63 
          SYMB      D64 
          SYMB   E
          VFD       18/0LEBC,12/#EBCDIC#
          SYMB   EOF
          SYMB   EOI
          SYMB   EOL
          SYMB   EOR
          SYMB   EOS
          SYMB   EOV
          SYMB   EQ 
          SYMB   ET 
          VFD    18/0LF,12/#FP# 
          SYMB   FKT
          SYMB   FT 
          VFD    18/0LFU,12/#FUP# 
          SYMB   GE 
          SYMB   GT 
          SYMB   IKT
          VFD    18/0LINP,12/#INPUT#
          SYMB   IS 
          SYMB   IT 
          VFD    18/3LI-O,12/#IO# 
          SYMB   KT 
          SYMB   LB 
          SYMB   LE 
          SYMB   LT 
          SYMB   N
          SYMB   NE 
          SYMB   NEW
          SYMB   NO 
          SYMB   NS 
          SYMB   OLD
          VFD    18/0LOUT,12/#OUTPUT# 
          SYMB   OVB
          SYMB   OVH
          SYMB   OVO
          SYMB   R
          SYMB      RET 
          SYMB   RT 
          SYMB   S
          SYMB   SKT
          SYMB   SQ 
          SYMB   ST 
          SYMB   T
          SYMB   TD 
          SYMB   TT 
          SYMB   U
          SYMB   UKT
          SYMB   UL 
          SYMB   UT 
          VFD    18/0LV,12/#VP# 
          VFD    18/0LVF,12/#VFP# 
          VFD    18/0LVFU,12/#VFUP# 
          VFD    18/0LVU,12/#VUP# 
          SYMB   WA 
          SYMB   WT 
          SYMB   YES
          SYMB   ZT 
 ENDSYMT  BSS    0
* 
*     THE FOLLOWING FIELDS ARE RECEIVED AS FORTRAN PARAMETER LIST 
*     ENTRIES INSTEAD OF AS THE DATA POINTED TO BY THE ENTRIES. 
* 
  ECHO 1,ADDR=(BZF,CDT,CPA,DCA,DCT,DX,EX,FWB,HRL,KA,LA,LGX,LX,PKA,WSA)
 ADDR_#A  MICRO 
          SPACE  1
 XPAND2   MACRO     A,N1,N2,C,D,E,F,G 
          VFD    30/0L_A,6/C,6/D,6/E
          IF     MIC,A_#A,2 
          VFD    6/0
          SKIP   1
          VFD    6/1
          VFD    3/F,3/G
 XPAND2   ENDM
          SPACE  1
* CALL /KWMTAB/ 
          LIST   -L 
*CALL /KWMTAB/
          LIST   *
 MICRO    OPSYN  FIELD
* CALL /KWMG/ 
          LIST   -L 
*CALL /KWMG/
          LIST   *
          PURGMAC MICRO 
          SYMSRT
 TABLE    BSS    0
          FITTAB
 ENDTAB   BSS    0
 PARALIST BSSZ   3
 ZERO     BSSZ   1                 PARAMETER LIST TERMINATOR
          END 
          IDENT  ER$PROC
          ENTRY  ER$PROC,ER$1 
          SST 
          COMMENT   CRM FTN INTERFACE ERROR PROCESSOR 
*#
* 
* 
*     PROCEDURE :  ER$PROC
*         THIS ROUTINE HANDLES SAAMFTN ERROR PROCESSING.
*             A- INPUT
*                B1=1 
*                B7=CODE FOR THE CALLING ROUTINE
*                ER$1 IS NON-ZERO FOR SETFIT CALLS
*                B2=ERROR CODE AS FOLLOWS 
*                  0-FIT ADDRESS NOT SPECIFIED
*                  1-FORMAT ERROR 
*                  2-UNDEFINED SYMBOL 
*                FOR ERROR TYPE TWO, X2 CONTAINS THE UNDEFINED SYMBOL 
*             B- OUTPUT 
*                AN ERROR MESSAGE IS PRINTED TO THE DAYFILE 
* 
* 
*#
 ER$PROC  BSSZ   1
          SA4    ER$1 
          ZR     X4,AA
          SB7    10                (FILE CALL ERROR)
 AA       SA3    B7+CALLTAB        FETCH CALL NAME
          BX6    X3 
          SA3    BLANKS 
          SB3    3
          GT     B7,B3,BB 
          SA3    EL 
 BB       BX7    X3 
          EQ     B2,B0,ER0         JUMP IF ERROR TYPE ZERO
          EQ     B2,B1,ER1         JUMP IF ERROR TYPE ONE 
          SA6    B1+MESS2 
          SA7    A6+B1
          MX0    48 
*   THE UNDEFINED SYMBOL IS PUT INTO THE ERROR MESSAGE
*   AND PRINTED TO THE DAYFILE IF THE SYMBOL CONTAINS 
*   NO CHARACTERS WHOSE VALUE IS GREATER THAN 57B.
          MX3    6
          SB3    8
 LOOP     BX4    X3*X2             MASK OFF LEFT-MOST CHARACTER 
          LX2    6
          LX4    6
          SX4    X4-60B 
          PL     X4,TOOBIG         JUMP IF CHAR. GREATER THAN 57B 
          SB3    B3-B1
          NE     B3,LOOP
          LX2    12 
          BX6    X2*X0             SET RIGHT 12 BITS TO ZERO
          EQ     STORE
 TOOBIG   SA2    BLANKS 
          BX6    X2*X0
 STORE    BSS    0
          SA6    SYM
          MESSAGE MESS2,,RECALL 
          EQ     ER$PROC
 ER0      SA6    B1+MESS0 
          SA7    A6+B1
          MESSAGE MESS0,,RECALL 
          EQ     ER$PROC
 ER1      SA6    B1+MESS1 
          SA7    A6+B1
          MESSAGE MESS1,,RECALL 
          EQ     ER$PROC
 TEMP     BSSZ   1
 ER$1     BSSZ   1
 CALLTAB  BSS    0
          DATA   10HENDFILE CA
          DATA   10HCLOSEM CAL
          DATA   10HIFETCH CAL
          DATA   10HSTOREF CAL
          DATA   10HSKIP CALL 
          DATA   10HOPENM CALL
          DATA   10HREWND CALL
          DATA   10HWEOR CALL 
          DATA 10HWTMK CALL 
          DATA   10HCHECK CALL
          DATA   10HFILE CALL 
 EL       DATA   10HL 
 MESS0    DATA   10H ERROR IN 
          BSSZ   2
 BLANKS   DATA   10H
          DATA   10H  FIT ADDR
          DATA   10HESS NOT SP
          DATA   7CECIFIED
 MESS1    DATA   10H ERROR IN 
          BSSZ   2
          DATA   10H
          DATA   10H      FORM
          DATA   8CAT ERROR 
 MESS2    DATA   10H ERROR IN 
          BSSZ   2
          DATA   10H
          DATA   10H  UNDEFINE
          DATA   10HD SYMBOL- 
 SYM      BSSZ   1
          END 
          IDENT  OPN$CLS
          ENTRY  CLOSEM,OPENM 
          EXT    SYM$SRH
          SST 
          COMMENT   CRM FTN INTERFACE (CLOSEM,OPENM)
 OPENM    BSSZ   1
          SB6       O.DONE
          SX6    A0 
          SA6    =SAVA0 
          SB7    5                 ER$PROC CODE FOR ERRORS FROM HERE
          SB1    1
          MX5       0              PLST$RM MASK REGISTER
          RJ        =XRM$ILD       SET UP REGISTERS 
          EQ     B4,B0,CALL        IF NO PARAMETERS SPECIFIED 
          SA4    =3LNEW 
          MX5    18 
          BX2    X5*X2             MASK OUT BLANKS
          IX5    X4-X2             COMPARE OPEN FLAG .VS. NEW 
          NZ     X5,OLD 
          STORE  A0,PD=OUTPUT 
          STORE  A0,ON=NEW
          EQ     AA 
 OLD      RJ     SYM$SRH
          EQ     B5,AA             JUMP IF UNDEFINED SYMBOL 
          STORE  A0,PD=X2 
          STORE  A0,ON=OLD
AA        EQ     B4,B1,CALL        IF THIRD PARAMETER NOT SPECIFIED 
          SA2    A3                ( CORRECT SYM$SRH FORMAT ) 
          RJ     SYM$SRH
          EQ     B5,CALL           JUMP IF UNDEFINED SYMBOL 
          STORE  X1,OF=X2 
CALL      OPENM  A0                ISSUE OPEN CALL
 O.DONE   BSS       0 
          SA5    =SAVA0 
          SA0    X5 
          EQ     OPENM
 CLOSEM   BSSZ   1
          SB6       C.DONE
          SB1    1
          SX6    A0 
          SA6    =SAVA0 
          SB7       B1             ER$PROC CODE FOR ERRORS FROM HERE
          MX5       0              PLST$RM MASK REGISTER
          RJ        =XRM$ILD       SET UP REGISTERS 
          EQ     B4,B0,CLSF.1      IF NO PARAMETERS EXCEPT FIT
          BX6       X3
          SA6       =SAVX3
          RJ     SYM$SRH           CLOBBERS X3 AND A1 
          EQ     B4,B1,CLSF        IF CLOSE TYPE NOT SPECIFIED
          SA3       =SAVX3
          SA4    =6LVOLUME
          IX5    X4-X3             COMPARE TYPE .VS. VOLUME 
          NZ     X5,CLSF     JUMP IF NOT CLOSE VOLUME 
 CLSV     EQ     B5,B0,CLSV.1  JUMP IF NO POSITION SPECIFIED
          STORE  X1,VF=X2    STORE VF IN FIT
CLSV.1    CLOSEM A0,,VOLUME        ISSUE VOLUME CLOSE 
          EQ        C.DONE
 CLSF     EQ     B5,B0,CLSF.1  JUMP IF NO POSITION SPECIFIED
          STORE  X1,CF=X2    STORE CF IN FIT
CLSF.1    CLOSEM A0,,FILE          ISSUE FILE CLOSE 
 C.DONE   BSS       0 
          SA5       =SAVA0
          SA0    X5 
          EQ     CLOSEM 
          END 
          IDENT  RMOPNX 
          ENTRY  RMOPNX 
          EXT       OPENM 
* 
          SST 
          COMMENT   CRM FTN INTERFACE (OBSOLETE, USE OPENM) 
 RMOPNX   BSSZ   1
          RJ     OPENM
          EQ     RMOPNX 
          END 
          IDENT  GET
          ENTRY  GET
          EXT    RM$STUF
[GE]      EQU    1
          SST 
          COMMENT   CRM FTN INTERFACE (GET) 
 GET      BSSZ   1
          SB6       GETDONE 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [GE]              CALLER TO STUFF
          SX5       30000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    GETDONE-1
          AX1    30 
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    GETDONE-1         STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          FETCH  A0,FO,X1,1,0 
          SX7    X1-#WA#
          ZR     X7,WATYPE         IF WA
          SX1    X1-#SQ#
          ZR     X1,WATYPE         IF SQ
          SX6    A3          X6 = KEY ADDRESS 
WATYPE    BSS    0
          GET    A0                MACRO CALL 
GETDONE   BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     GET
          END 
          IDENT  PUT
          ENTRY  PUT
          EXT    RM$STUF
[PU]      EQU    0
          SST 
          COMMENT   CRM FTN INTERFACE (PUT) 
 PUT      BSSZ   1
          SB6       PUTDONE 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [PU]              CALLER TO STUFF
          SX5       24000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    PUTDONE-1
          AX1    30 
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    PUTDONE-1         STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          FETCH  A0,FO,X1,1,0 
          SX1    X1-#WA#
          ZR     X1,WATYPE         IF WA, THEN SKIP FOLLOWING OPERATION 
          SX6    A4          X6 = KEY ADDRESS 
WATYPE    BSS    0
          #SA0#     ,A0 
          #CALL#    PUT 
PUTDONE   BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     PUT
          END 
          IDENT  REPLC
          ENTRY  REPLC
          EXT    RM$STUF
[RE]      EQU    0
          SST 
          COMMENT   CRM FTN INTERFACE (REPLC) 
 REPLC    BSSZ   1
          SB6       REPDONE 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [RE]              CALLER TO STUFF
          SX5       24000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    REPDONE-1
          AX1    30 
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          SX6    A4          X6 = KEY ADDRESS 
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    REPDONE-1         STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          #SA0#     ,A0 
          #CALL#    REPL
REPDONE   BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     REPLC
          END 
          IDENT  DLTE 
          ENTRY  DLTE 
          EXT    RM$STUF
[DE]      EQU    4
          SST 
          COMMENT   CRM FTN INTERFACE (DLTE)
 DLTE     BSSZ   1
          SB6       DELDONE 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [DE]              CALLER TO STUFF
          SX5       20000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    DELDONE-1
          SB2    A5          B2 = EX ADDRESS
          AX1    30 
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    DELDONE-1         STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          #SA0#     ,A0 
          #CALL#    DLT 
DELDONE   BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     DLTE 
          END 
          IDENT  GETN 
          ENTRY  GETN 
          EXT    RM$STUF
[GN]      EQU    2
          SST 
          COMMENT   CRM FTN INTERFACE (GETN)
 GETN     BSSZ   1
          SB6       GTNDONE 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [GN]              CALLER TO STUFF
          SX5       30000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    GTNDONE-1
          AX1    30 
          SX6    A3          X6 = KEY ADDRESS 
          SB2    A4          B2 = EX ADDRESS
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    GTNDONE-1         STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          GETN   A0                MACRO CALL 
GTNDONE   BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     GETN 
          END 
          IDENT     GETNR 
          COMMENT   CRM FTN INTERFACE (GETNR) 
          ENTRY     GETNR 
          EXT    RM$STUF
 [GN]     EQU    2
          SST 
 GETNR    BSSZ      1 
          SB6       GTNRDON 
          SX6    A0 
          SA6    =SAVA0      SAVE A0
          SB1    1
          SB5    [GN]        CALLER TO STUFF
          SX5       30000B         PLST$RM MASK REGISTER
          RJ     RM$STUF     SETUP REGISTERS
          SA1    GTNRDON-1
          AX1    30 
          SX6    A3          X6 = KEY ADDRESS 
          SB2    A4          B2 = EX ADDRESS
          LX1    30          CHOP OFF LOWER 30 BITS AT RUN TIME 
          BX0    X1+X0       BUILD REG USAGE WORD 
          BX1    X7 
          BX7    X0 
          SA7    GTNRDON-1   STORE REG USAGE WORD 
          BX7    X1          RESTORE X7 
          GETNR     A0
 GTNRDON  BSS       0 
          SA5    =SAVA0 
          SA0    X5          RESTORE A0 
          EQ        GETNR 
          END 
          IDENT  SEEKF
          ENTRY  SEEKF
          EXT    RM$STUF
[SE]      EQU    5
          SST 
          COMMENT   CRM FTN INTERFACE (SEEKF) 
 SEEKF    BSSZ   1
          SB6       SEKDONE 
          SX6    A0 
          SA6    =SAVA0 
          SB1       1 
          SB5    [SE]              CALLER TO STUFF
          SX5       20000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    SEKDONE-1
          AX1    30 
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          BX1    X7                SAVE X7
          BX7    X0 
          SB2    A5          B2 = EX ADDRESS
          SA7    SEKDONE-1         STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          SEEK   A0                MACRO CALL 
SEKDONE   BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     SEEKF
          END 
          IDENT  STARTM 
          ENTRY  STARTM 
*#
*1CD  STARTM (FTNIF)
*0D   PURPOSE 
*0        PROVIDE A FORTRAN INTERFACE TO THE CRM START MACRO. 
*0D   CALL
*0        CALL STARTM(FIT,KA,KP,MKL,EX) 
*0D   PARAMETERS
*0        FIT       FIT ADDRESS.
*         EX        ADDRESS OF ERROR EXIT ROUTINE.
*         KA        ADDRESS OF KEY. 
*         KP        BEGINNING CHARACTER POSITION ON KEY.
*         MKL       MAJOR KEY LENGTH IN CHARACTERS. 
*0D   ACTION
*0        SAVE A0, CALL RM$STUF TO LOAD THE CALLING SEQUENCE PARAMETERS 
*         INTO REGISTERS, INVOKE THE START MACRO, RESTORE A0, AND 
*         RETURN TO USER
*0D   REGISTERS USED
*0        ALL 
*0D   OTHER CODE REQUIRED 
*0        PROGRAMS- RM$STUF,CTL$RM
*         MACROS-   START (CRMTEXT) 
*#
          EXT    RM$STUF
          SST 
          COMMENT   CRM FTN INTERFACE (STARTM)
 [ST]     EQU    8D 
          SPACE  2
 STARTM   BSSZ   1
          SB6       STRTDONE
          SX6    A0                ALL FTN PROGS MUST SAVE A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [ST]              CALLER TO STUFF
          SX5       20000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    STRTDONE-1        LOAD WORD CONTAINING EQ STRT$RM
          AX1    30                CHOP OFF LOWER 30 BITS (COMPILE TIME)
          LX1    30                AND ADD 30 BITS AT RUN TIME
          BX0    X1+X0
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    A1 
          BX7    X1                RESTORE X7 
          SB2    A5          B2 = EX ADDRESS
          START  A0 
 STRTDONE BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     STARTM 
          END 
          IDENT  FLUSHM 
          COMMENT   CRM FTN INTERFACE (FLUSHM)
          ENTRY     FLUSHM,FLUSH1 
 FLUSHM   BSSZ   1
          SB6       FSHM.RTN
          SX6    A0 
          SA6    =SAVA0      SAVE A0
          SA1    A1          ENSURE X1 IS LOADED
          FLUSHM X1 
 FSHM.RTN BSS       0 
          SA5    =SAVA0 
          SA0    X5          RESTORE A0 
          EQ     FLUSHM 
 FLUSH1   BSSZ      1 
          SB6       FSH1.RTN
          SX6       A0
          SA6       =SAVA0         SAVE A0
          SA1       A1             ENSURE X1 IS LOADED
          SX6       X1             PICK UP FIT ADDRESS
          SA1       X1
          MX2       42
          BX1       X1*X2          PICK UP LFN
          BX6       X6+X1          BUILD TABLE WORD 
          SA6       FITLIST        PUT INTABLE
          SX1       A6             PUT ADDRESS OF TABLE IN X1 
          FLUSHM    X1
 FSH1.RTN BSS       0 
          SA5       =SAVA0
          SA0       X5             RESTORE A0 
          EQ        FLUSH1
 FITLIST  BSSZ      2 
          END 
          IDENT  SKIP 
          ENTRY  SKIP 
          SST 
          COMMENT   CRM FTN INTERFACE (SKIP)
 [SK]     EQU    7
 SKIP     BSSZ   1
          SB6       RETURN
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [SK]              CALLER TO STUFF
          MX5       0              PLST$RM MASK REGISTER
          RJ     =XRM$STUF         SET UP REGISTERS 
          SA2    X2                X2=ADR OF PARAM                      P 
          NG     X2,B 
          SA1    SKF-1
          EQ     MODIFY 
 B        BSS    0
          SA1    SKB-1
 MODIFY   BSS    0
          AX1    30 
          LX1    30 
          BX0    X1+X0
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    A1 
          BX7    X1                RESTORE X7 
          NG     X2,BACK           SKIPBL IF COUNT IS NEGATIVE
          SKIPFL A0                ISSUE SKIP FORWARD 
 SKF      BSS    0
          EQ     RETURN 
BACK      BX2    -X2
          SKIPBL A0                ISSUE SKIP BACKWARD
 SKB      BSS    0
RETURN    SA5    =SAVA0 
          SA0    X5 
          EQ     SKIP 
          END 
          IDENT  REWND
          ENTRY  REWND
          SST 
          COMMENT   CRM FTN INTERFACE (REWND) 
 REWND    BSSZ   1
          SB6       REW.RTN 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SA1    A1          ENSURE THAT X1 IS LOADED 
          REWINDM X1
 REW.RTN  BSS       0 
          SA5    =SAVA0 
          SA0    X5 
          EQ     REWND
          END 
          IDENT  GETP 
          ENTRY  GETP 
          EXT    RM$STUF
[GP]      EQU    3
          SST 
          COMMENT   CRM FTN INTERFACE (GETP)
 GETP     BSSZ   1
          SB6       GTPDONE 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB2    B0                USED IN RM$STUF
          SB5    [GP]              CALLER TO STUFF
          SX5       20000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    GTPDONE-1
          AX1    30 
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          SB2    A5          B2 = EX ADDRESS
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    GTPDONE-1         STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          GETP   A0,,,,,B5         PASS SKIP IN B5
GTPDONE   BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     GETP 
 XSKIP    DATA   4LSKIP 
          END 
          IDENT  PUTP 
          ENTRY  PUTP 
          EXT    RM$STUF
 [PP]     EQU       6 
          SST 
          COMMENT   CRM FTN INTERFACE (PUTP)
 PUTP     BSSZ   1
          SB6       PPDONE
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SB5    [PP]              CALLER TO STUFF
          SB2    B1                USED IN RM$STUF
          SX5       20000B         PLST$RM MASK REGISTER
          RJ     RM$STUF           SET UP REGISTERS 
          SA1    PPDONE-1 
          AX1    30 
          LX1    30                CHOP OFF LOWER 30 BITS AT RUN TIME 
          SB2       A5        ERROR EXIT
          BX0    X1+X0             BUILD REGISTER USAGE WORD
          BX1    X7                SAVE X7
          BX7    X0 
          SA7    PPDONE-1          STORE REGISTER USAGE WORD
          BX7    X1                RESTORE X7 
          PUTP      A0,,,,,,B5
PPDONE    BSS    0
          SA5    =SAVA0 
          SA0    X5 
          EQ     PUTP 
          END 
          IDENT  WEOR 
          ENTRY  WEOR 
          SST 
          COMMENT   CRM FTN INTERFACE (WEOR)
 WEOR     BSSZ   1
          SB6       WEOR.RTN
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          MX5       0              PLST$RM MASK REGISTER
          RJ        =XRM$ILD       SET UP REGISTERS 
          WEOR   A0,X2             ISSUE WEOR 
 WEOR.RTN BSS       0 
          SA5    =SAVA0 
          SA0    X5 
          EQ     WEOR 
          END 
          IDENT  WTMK 
          ENTRY  WTMK 
          SST 
          COMMENT   CRM FTN INTERFACE (WTMK)
 WTMK     BSSZ   1
          SB6       WTMK.RTN
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SA1    A1          ENSURE THAT X1 IS LOADED 
          WTMK   X1 
 WTMK.RTN BSS       0 
          SA5    =SAVA0 
          SA0    X5 
          EQ     WTMK 
          END 
          IDENT  ENDFILE
          ENTRY  ENDFILE
          SST 
          COMMENT   CRM FTN INTERFACE (ENDFILE) 
 ENDFILE  BSSZ   1
          SB6       ENDF.RTN
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SA1    A1          ENSURE THAT X1 IS LOADED 
          ENDFILE X1
 ENDF.RTN BSS       0 
          SA5    =SAVA0 
          SA0    X5 
          EQ     ENDFILE
          END 
          IDENT  CHECK
          ENTRY  CHECK
          SST 
          COMMENT   CRM FTN INTERFACE (CHECK) 
 CHECK    BSSZ   1
          SB6       CHK.RTN 
          SX6    A0 
          SA6    =SAVA0 
          SB1    1
          SA1    A1          ENSURE THAT X1 IS LOADED 
          CHECK  X1 
 CHK.RTN  BSS       0 
          SA5    =SAVA0 
          SA0    X5 
          EQ     CHECK
          END 
          IDENT  FCL$RM 
          ENTRY  LDL$RM,ZAJ$RM
          TITLE  FCL$RM - FCL/CRM OVERLAY INTERFACE 
          COMMENT LINK/DELINK STATIC CAPSULES.
          SST 
          LIST   G
          TITLE  LDL$RM - LINK/DELINK STATIC CAPSULES.
*#
*1DC      LDL$RM
*0D   LDL$RM - LINK OR DELINK A STATICALLY LOADED CAPSULE FORM FTN. 
*0D   ENTRY 
*0        X2 = FWA OF OVERLAY BEING LOADED OR UNLOADED. 
*         AX5= LIST OF THE FORM:  
*                VFD  42/0L_NAME1$RM,18/=Y_NAME1$RM 
*                VFD  42/0L_NAME2$RM,18/=Y_NAME2$RM 
*                 ... 
*                CON  0 
*0D   ACTION
*0        THERE ARE THREE ENTRY TABLES IN CRM - ONE IN CTL$RM, AND ONE E
*         EACH IN GET$RM AND PUT$RM.  IF AN =Y IN THE LIST POINTS TO AN 
*         ADDRESS ABOVE THE FWA OF THE OVERLAY, THEN THE ADDRESS NEEDS
*         TO BE LINKED OR DELINKED.  IF THE CORRESPONDING ENTRY IN THE
*         APPROPRIATE ENTRY TABLE IS FILLED IN, THEN DELINK IT; ELSE
*         LINK IT.  THE CHOICE OF ENTRY TABLE IS DRIVEN BY THE NAME-- 
*         GET$X AND PUT$X ("X" NOT "RM") MEANS TO USE THE GET$RM OR 
*         PUT$RM PSEUDO ENTRY TABLE, ELSE USE THE CTL$RM TABLE. 
*0D   REGISTERS 
*0        B6 IS PRESERVED.
*0D   CALLERS 
*0        THIS ROUTINE IS CALLED ONLY FROM THE OVERLAY ROUTINE IN FCL.
*#
 LDL$RM   SPACE  4,8
          ENTRY  LDL$RM 
 LDL$RM 
          ZR        X5,LDL$RM      PROTECT AGAINST EMPTY LIST 
          SB2       X2             FWA OF OVERLAY READ OR OVERWRITE 
          SB1       1 
          MX0       42
  
 LLOOP    BSS       0 
          BX4       X5             LIST ENTRY : CAPSULE NAME/ADDRESS
          LX5       3*6 
          SB3       X5-3RGET
          SB7       X4             ADDRESS OF CAPSULE FROM LIST ENTRY 
          SB4       B0
          ZR        B3,GETPUT      IF GET$X 
          SB4       B1
          SB3       X5-3RPUT
          ZR        B3,GETPUT      IF PUT$X 
          GE        B2,B7,NEXTE    IF ADDRESS IS NOT IN OVERLAY 
 CTL      SA1       =XRM$PL        HEADER FOR ENTRY TABLE IN CTL$RM 
          BX7       X1
          LX7       12
          SA1       A1+B1 
          AX7       -12 
          SB5       X7             TRUE LENGTH OF TABLE 
          EQ        ELOOP 
  
 GETPUT   BSS       0 
          BX3       X4
          AX3       4*6 
          SB3       X3-3R$SQ
          ZR        B3,MAINGP      IF GET$SQ OR PUT$SQ
          GE        B2,B7,NEXTE    IF ADDRESS IS NOT IN OVERLAY 
          PL        X5,CTL         IF NOT YYY$
          SA1       GPPTR+B4
          SB5       #PGPLSZ#
          SA1       X1+0
  
 ELOOP    BX7       X1-X4 
          AX7       18
          ZR        X7,GOTIT       IF NAMES MATCH 
          SA1       A1+B1          NEXT ENTRY IN ENTRY TABLE
          SB5       B5-B1 
          GT        B5,ELOOP       LOOP THRU ENTRY TABLE
          MX7       42
          SA1       MISCAP+2
          BX6       X7*X4          STRIP THE ADDRESS FIELD FROM NAME$RM 
          BX7       X6+X1 
          SA7       A1
          MESSAGE   MISCAP,,R 
          JP        *+1S17         ----TEMP----(SHOULD NEVER GET HERE)
  
 GOTIT    SB3       X1
          BX6       X0*X1 
          GT        B3,B0,ISDLK    IF ADDR EXISTS, DELINK 
          BX7       -X0*X4         ELSE LINK USING ADDR IN LIST 
          BX6       X6+X7 
 ISDLK    SA6       A1             RESTORE IN ENTRY TABLE 
  
 NEXTE    SA5       A5+B1          NEXT ENTRY IN LIST 
          NZ        X5,LLOOP       IF NOT THRU
          EQ        LDL$RM         EXIT 
  
 MAINGP   SX7       X4-#PGPLSZ# 
          NG        X7,NEXTE
          SA7       GPPTR+B4       SAVE ADDR OF GET/PUT $SQ 
          GE        B2,B7,NEXTE    IF ADDRESS IS NOT IN OVERLAY 
          EQ        CTL 
  
 MISCAP   DATA   C$  BAM ENTRY POINT   :::::::   NOT FOUND.$
 GPPTR    BSSZ      2              ADDR OF GET$SQ AND PUT$SQ
  
          TITLE  ZAJ$RM - ZERO OUT ALL JUMPS IN LOF$RM FITS 
*#
*1DC      ZAJ$RM
*0D   ZAJ$RM - ZAP ALL (FIT FIELD) JUMPS IN LIST OF FILES FITS. 
*0D   ENTRY 
*0        NONE
*0D   ACTION
*0        THE FIT FIELDS FOJP, RTJP, FOJG, RTJG WILL BE ZEROED OUT FOR
*         ALL VALID FITS LOCATED IN THE LIST OF FILES AT LOF$RM.
*0D   CALLERS 
*0        THIS ROUTINE IS CALLED ONLY FROM THE OVERLAY ROUTINE IN FCL.
*#
 ZAJ$RM   SPACE  4,8
 ZAJ$RM 
          SA2       =XLOF$RM
          SA2       X2+0
  
 ZLOOP    SA2       A2+1
          NG        X2,ZLOOP       NEGATIVE ENTRY SIGNIFIES CLOSED FILE 
          ZR        X2,ZAJ$RM      ZERO WORD SIGNIFIES END OF TABLE 
          SB2       X2
          SA0       X2
          LE        B2,B0,ZLOOP    TEST FOR INVALID FIT ADDRESS 
          F.RM   FTS,X1,-#MNF#
          NG     X1,ZLOOP          SKIP NON-CRM FETS
          SET.RM    PUTJ,0
          SET.RM    GETJ,0
          EQ        ZLOOP 
  
          END 
          IDENT     PLST$RM 
          ENTRY     PLST$RM 
          ENTRY     PL$FWA,PL$BCP   USED BY STOREF
          SST 
          LIST      C,F,X 
          COMMENT   CRM FTN INTERFACE (SETUP PARAMETER LIST)
* 
* 
* FIELD.P(OSITION) COUNTS FROM 0 TO 59, LEFT TO RIGHT 
* POSITION COUNTS FROM 0 TO 9, LEFT TO RIGHT
 FWA.P    EQU       36D            FWA OF PARAMETER - POSITION
 FWA.S    EQU       24D            FWA OF PARAMETER - FIELD LENGTH(BITS)
 BCP.P    EQU       32D            BEGINNING CHARACTER POSITION OF PARAM
 BCP.S    EQU        4D            BCP FIELD LENGTH(BITS) 
 LEN.P    EQU       12D            PARAMETER LENGTH - POSITION
 LEN.S    EQU       18D            LENGTH OF PARAM LENGTH FIELD(BITS) 
  
 SWAP     MACRO     A,B 
* 
*         THIS MACRO WILL SWAP CONTENTS OF X.A AND X.B, 
*          USING NO OTHER REGISTERS.
* 
          BX.B      X.A-X.B 
          BX.A      X.A-X.B 
          BX.B      X.A-X.B 
          ENDM
  
* 
 PL$FWA   BSSZ      1 
 PL$BCP   BSSZ      1 
 MASKTBL  DATA      77777777777777777777B 
          DATA      00777777777777777777B 
          DATA      00007777777777777777B 
          DATA      00000077777777777777B 
          DATA      00000000777777777777B 
          DATA      00000000007777777777B 
          DATA      00000000000077777777B 
          DATA      00000000000000777777B 
          DATA      00000000000000007777B 
          DATA      00000000000000000077B 
          DATA      00000000000000000000B 
* 
 PLSTPTR  BSSZ      1              PARAMETER LIST POINTER 
* 
 APLIST   BSSZ      10D            MODIFIED APLIST TO BE USED BY CRM
 PARAMS   BSSZ      10D            MODIFIED PARAMETER LIST TO BE USED 
* 
* 
 PLST$RM  EQ        *+1S17         ( *--- ENTRY POINT ---* )
* 
          SX2       40000B         MASK BIT FOR FIRST PARAMETER (FIT) 
          SX6       A1-1
          BX5       X5+X2          MERGE BIT FOR FIT WITH MASK REGISTER 
          SB1       B0             USE B1 AS APLIST STORE OFFSET
          LX5       44             PREPARE 15-BIT-MASK REGISTER 
          SA6       PLSTPTR 
* 
 LOOP     BSS       0 
          SA2       PLSTPTR 
          SA1       X2+1           PICK UP NEXT PARAMETER LIST ELEMENT
  
          ZR        X1,DONE        ZERO TERMINATES THE PARAMETER LIST 
          MX6       0 
          SA6       PL$FWA         CLEAR EXTERNAL FWA 
          SA6       PL$BCP         CLEAR EXTERNAL BCP 
          LX5       1              SHIFT MASK REGISTER INTO POSITION
  
 M.       IFNE      #BETA#,0
          PL        X5,NEXT        NOT AN ADDRESS 
          PL        X1,NEXT        NOT IN LCM 
          SA3       APLIST
          SA0       X3             THE FIT MUST NOT BE IN LCM 
          F.RM      AAM,3,X3
          NZ        X3,ERROR2      AAM FILE 
          MX7       1 
          BX1       -X7*X1         REMOVE 2**59 
          LX7       21+1
          BX1       X1+X7          SET BIT 21 
 NEXT     BSS       0 
 M.       ENDIF 
          MX3       LEN.S 
          SX6       A1
          LX3       60-LEN.P
          SA6       PLSTPTR        ADVANCE PARAMETER LIST POINTER 
          BX6       X3*X1          EXTRACT LENGTH FIELD FROM PARAM LIST ELEMENT 
  
          NZ        X6,FIXIT       IF LENGTH IS NON-ZERO,LEFT JUSTIFY PARAM 
* OLD STYLE PARAMETER LIST
  
          BX6       X1
  
 SV.APLST BSS       0 
          SA6       APLIST+B1      SAVE APLIST ELEMENT AS PARAM LIST ELEMENT
          SB1       B1+1           ADVANCE APLIST STORE OFFSET
          EQ        LOOP
  
 FIXIT    BSS       0 
          LX6       LEN.S+LEN.P    RIGHT JUSTIFY LENGTH FIELD FOR LATER USE 
          SX3       X6-11D
          NG        X3,NO.TRUNC 
          SX6       10D            TRUNCATE PARAMETER TO 10 CHARACTERS
 NO.TRUNC BSS       0 
  
          MX3       BCP.S 
          MX7       FWA.S 
          LX3       60-BCP.P
          LX7       60-FWA.P
          BX3       X3*X1 
          BX7       X7*X1 
  
          LX3       BCP.S+BCP.P    RIGHT JUSTIFY BCP FIELD FOR LATER USE
          SWAP      3,6 
          SA6       PL$BCP         SAVE EXTERNAL BCP
          SWAP      3,6 
  
          LX7       FWA.S+FWA.P    RIGHT JUSTIFY FWA FIELD
 .BETA    IFNE      #BETA#,0
          PL        X1,SAV.FWA
          MX3       1 
          LX3       21+1
          BX7       X7+X3          SET BIT 21 
          SA3       PL$BCP
 SAV.FWA  BSS       0 
 .BETA    ENDIF 
          SA7       PL$FWA         SAVE EXTERNAL FWA
  
          PL        X5,CONTINUE    NOT WSA OR KA IF ZERO FLAG 
          NZ        X3,ERROR       IF BCP IS NON-ZERO, ERROR
          SX6       X7
          EQ        SV.APLST
 ERROR    BSS       0 
          SB1       1 
          SA1       APLIST
          SA0       X1
          CRMEP     ES=321B,FNF=1,EES=0   FATAL ERROR ABORT 
 ERROR2   BSS       0 
          SB1       1 
          SA1       APLIST
          SA0       X1
          CRMEP     ES=557B,FNF=1,EES=0 
  
  
 CONTINUE BSS       0 
* FINISHED WITH THE PARAMETER LIST ELEMENT - GET THE PARAMETER ITSELF 
          SA1       X7             PICK UP FIRST HALF OF THE PARAMETER
          SA2       MASKTBL+X3     MASK TABLE OFFSET AND BCP ARE THE SAME HERE
          BX7       X1*X2          MASK OFF FIRST HALF OF PARAMETER 
  
          SX2       6 
          IX2       X2*X3          BCP*6 GIVES POSITION OFFSET IN BITS
          SB4       X2
          LX7       B4             LEFT JUSTIFY THE FIRST HALF OF THE PARAMETER 
  
          SX2       10D 
          IX3       X2-X3          COMPUTE NUMBER OF CHARACTERS MOVED 
          IX2       X6-X3          COMPUTE NUMBER OF CHARACTERS YET TO MOVE 
          ZR        X2,ENDLOOP
          PL        X2,MORE 
  
* OTHERWISE, WE MOVED TOO MUCH
          SA2       MASKTBL+X6
          BX7       -X2*X7         TRUNCATE THE PARAMETER TO LENGTH CHARACTERS
  
 ENDLOOP  BSS       0 
  
          MX1       6 
          SX2       6 
          IX3       X2*X6 
          SX2       66D 
          IX3       X2-X3          ( 66 - ( 6 * LENGTH )) 
          SB4       X3
          LX1       B4             SHIFT MASK TO (LENGTH-1) CHAR POS
  
          SB4       X3-6
          SX2       55B 
          LX2       B4             SHIFT 55B COMPARE TO (LENGTH-1) POS
  
          SB4       1              INITIALIZE COUNTER AS -1 
  
 DRPBLNKS BSS       0 
          SB4       B4-1
          BX3       X1*X7          EXTRACT BYTE FROM PARAMETER
          IX3       X3-X2          PERFORM BLANK COMPARE
          NZ        X3,ENDROP 
          SX3       X6+B4 
          ZR        X3,ENDROP 
  
          LX1       6 
          LX2       6 
          EQ        DRPBLNKS
  
 ENDROP   BSS       0 
          SX2       X6+B4 
          SA1       MASKTBL+X2
          BX7       -X1*X7         REMOVE BLANK PADDING 
  
          SX6       PARAMS+B1 
          SA7       X6             SAVE THE PARAMETER IN THE PARAMS LIST
          EQ        SV.APLST
  
 MORE     BSS       0 
          SA1       A1+1           PICK UP SECOND HALF OF PARAMETER 
          SA2       MASKTBL+X2     MASK TABLE OFFSET = CHARS YET TO MOVE
          BX1       -X2*X1         MASK OFF SECOND HALF OF PARAMETER
  
          SX2       6 
          IX2       X2*X3 
          SX3       60
          IX2       X3-X2 
          SB4       X2
          LX1       B4
  
          BX7       X7+X1          CONCATENATE THE FIRST AND SECOND HALVES
          EQ        ENDLOOP 
  
 DONE     BSS       0 
          MX6       0 
          SA6       APLIST+B1 
          SB1       1 
          SA1       APLIST
          EQ        PLST$RM 
  
          END 
          IDENT     RM$ILD
          ENTRY     RM$ILD
          SST 
          B1=1
 .BETA    IFNE      #BETA#,0
          ENTRY     SAV$ADR 
 .BETA    ENDIF 
          COMMENT   CRM FTN INTERFACE (SETUP COMMON PARAMETERS) 
*#
* 
*         RM$ILD: 
*            THIS ROUTINE OFFERS THE CAPABILITIES OF LOADING UP TO THREE
*            PARAMETERS (INTO A0, X2, AND X3 RESPECTIVELY) WITHOUT
*            WITHOUT THE REGISTER SWAPPING AND REGISTER USAGE CHECKING
*            OF STUFF.  THE FOLLOWING ROUTINES CALL RM$LOAD:  
*              OPENM
*              CLOSEM 
*              WEOR 
*              STOREF 
*              IFETCH 
*         REGISTER USAGE: 
*            B4 WILL BE RETURNED WITH THE NUMBER OF PARAMETERS FOUND, 
*              NOT INCLUDING THE FIT, WHOSE PRESENCE IS ASSUMED 
* 
*#
 RM$LOAD  BSS 
 RM$ILD 
          RJ     =XPLST$RM
          SA1    A1                BE SURE THAT X1 IS LOADED
          SB4    B0                B4 WILL BE USED TO COUNT PARAMETERS
          SA0    X1                A0=FIT 
          ZR     X1,RM$LOAD        IF NO FIT, THEN EXIT 
          SA2    A1+B1             FETCH FIRST NON-FIT PARAMETER
          ZR     X2,RM$LOAD        IF NOT SPECIFIED, RETURN 
          SB4    B4+B1             BUMP PARAMETER COUNTER 
          SA3    A2+B1             LOAD NEXT ADDRESS BEFORE A2 DESTROYED
          SA2    X2                LOAD PARAMETER 
          ZR     X3,RM$LOAD        IF NEXT PARAMETER NOT SPECIFIED, RETURN
          SB4    B4+B1             BUMP PARAMETER COUNTER 
 .BETA    IFNE      #BETA#,0
          PL        X3,SKP.BETA 
          MX6       37             CHECK FOR BIT 59 LCM FLAG
          LX6       59
          BX6       X6*X3 
          NZ        X6,SKP.BETA 
          MX6       1 
          BX3       -X6*X3         REMOVE 2**59 
          LX6       21+1
          BX3       X6+X3 
          BX6       X3
          SA6       SAV$ADR        SAVE LCM ADDRESS 
          EQ        END.BETA
 SKP.BETA BSS       0 
          SA3       X3
          SX6       A3
          SA6       SAV$ADR        SAVE SCM ADDRESS 
 END.BETA BSS       0 
 .BETA    ELSE
          SA3       X3
 .BETA    ENDIF 
          EQ     RM$LOAD
 .BETA    IFNE      #BETA#,0
 SAV$ADR  DATA      0 
 .BETA    ENDIF 
          END 
          IDENT  RM$STUF           ROUTINE TO STUFF REGISTERS 
          COMMENT   CRM FTN INTERFACE (SETUP PARAMETER REGISTERS) 
          ENTRY  RM$STUF
  
  
*#
* 
* 
* 
* 
*         (NOTE:  STUFF IS USED IN COMMENTS TO REFER TO RM$STUF.) 
* 
* 
*         THE STUFF ROUTINE:  
*            THIS ROUTINE PLACES ALL OF THE SPECIFIED PARAMETERS
*            IN THE PROPER REGISTERS IN PREPARATION FOR THE APPROPRIATE 
*            CRM MACRO CALL.  THE THREE MAJOR STEPS ARE:  
*               1. PLACE THE PARAMETERS INTO SEQUENTIALLY ORDERED REGS
*               2. EXCHANGE THE REGISTERS SO THAT THEY ARE IN PROPER CRM
*                  MACRO ORDER
*               3. SET UP THE REGISTER USAGE WORD FOR THE MACRO CALL
* 
*             REGISTER USAGE: 
*                INPUT:   A1 POINTS TO PARAMETER LIST 
*                OUTPUT:  A0=FIT ADDRESS
*                         X0=REGISTER USAGE WORD
*                         X2-X7 CONTAIN ANY SPECIFIED PARAMETERS
* 
*         THE FOLLOWING MACROS ARE USED BY STUFF: 
*            SETBIT      P1,P2
*               SETS THE BIT SPECIFIED BY P2 IN THE FIELD SPECIFIED 
*               BY P1.  (USES X1 AND X7)
*            EX          P1,P2
*               EXCHANGES REGISTERS SPECIFIED BY P1 AND P2. 
*               (USES NO OTHER REGISTERS) 
*            CHKBIT      P1,P2,P3 
*               CHECKS BIT 59 OF PARAMETER 1.  IF IT IS ONLY BIT SET, 
*               NOTHING IS DONE.  OTHERWISE, THE BIT SPECIFIED BY P3
*               IS SET IN THE FIELD SPECIFIED BY P2.
*               (USES X1 AND CALLS SETBIT)
*            PARTCHK
*               CHECKS X7 FOR TERM IF PUTP, OR X6 FOR SKIP IF GETP
*               (USES X0 AND X1)
* 
* 
* 
* 
* 
*#
  
  
EX        MACRO  XREG1,XREG2
          B_XREG2  XREG1-XREG2
          B_XREG1  XREG1-XREG2
          B_XREG2  XREG1-XREG2
EX        ENDM
  
  
SETBIT    MACRO  VAL
          MX1    1
          LX1    VAL+1
          BX0    X0+X1
SETBIT    ENDM
  
  
CHKBIT    MACRO  XREG,VAL 
          LOCAL  DONE 
          MX1    1
          BX1       XREG-X1 
          ZR     X1,DONE           ONLY BIT 59 WAS SET
          SETBIT VAL
DONE      BSS    0
CHKBIT    ENDM
  
  
TEMP      BSS    1                 STORAGE LOCATION FOR USAGE BITS
  
  
  
RM$STUF   BSS    1                 ENTRY INTO STUFF ROUTINE 
*#
* 
* 
*         UPON ENTRY INTO STUFF IT IS ASSUMED THAT B5 CONTAINS
*         THE FOUR BIT MNEUMONIC OF THE CALLING ROUTINE, AS FOLLOWS 
*              [PU]  PUT
*              [PP]  PUTP 
*              [GE]  GET
*              [GP]  GETP 
*              [GN]  GETN 
*              [DE]  DELETE 
*              [RE]  REPLACE
*              [SE]  SEEK 
*              [SK]  SKIP 
*              [ST]  START
* 
* 
*#
          RJ     =XPLST$RM
          SA1    A1                INSURE LOADING OF X1 
          MX7    0
          SA0    X1                A0=FIT (EVEN IF NO FIT GIVEN)
          SA7    TEMP              CLEAR TEMP 
          MX0    0                 INITIALIZE X0 IN CASE EARLY EXIT 
          ZR     X1,RM$STUF        IF NO FIT, THEN EXIT 
* 
* 
* 
*         PART ONE
* 
* 
* 
* 
* 
*         HERE WE MUST INITIALIZE EACH PARAMETER TO  A NEGATIVE 
*         VALUE JUST IN CASE THE CORRESPONDING PARAMETER IS 
*         NOT PRESENT 
* 
* 
          MX2    1                 SET TO NEGATIVE
          MX3    1                 SET TO NEGATIVE
          MX4    1                 SET TO NEGATIVE
          MX5    1                 SET TO NEGATIVE
          MX6    1                 SET TO NEGATIVE
          MX7    1                 SET TO NEGATIVE
* 
* 
*         HERE WE PLACE PARAMETERS INTO REGISTERS IN A SEQUENTIAL MANNER
* 
*         (NOTE THAT IN THE CASE OF X2 AND X7, THE ADDRESS AND NOT
*            THE VALUE IS PLACED IN THE REGISTER.  THIS IS DONE 
*            BECAUSE EACH ROUTINE WILL HAVE AN ADDRESS IN THOSE 
*            POSITIONS.  OTHER REGISTERS SHOULD HOLD ADDRESSES IN 
*            SOME CASES, DEPENDING UPON THE OPERATION, AND SINCE
*            THERE IS NO CONSISTENCY THOSE REGISTERS WILL BE SET
*            TO THE CORRESPONDING ADDRESS BY THE CALLING ROUTINE.)
* 
* 
          SA1    A1+B1             FETCH NEXT PARAMETER ADDRESS 
          ZR     X1,NOMORE         IF PARAMETER LIST EXHAUSTED
          BX0    X1-X7
          NZ     X0,OK2            PARAMETER NOT EQUAL TO 2**59 
          AX1    1                 EXTEND BIT 59 TO 58 TO DIFFERENTIATE 
*                                  PARAM VALUE 2**59 FROM MISSING PARAM 
*                                  FLAG 
OK2       BSS    0
          BX2    X1                X2=ADDRESS 
          SA1    A1+B1             FETCH NEXT PARAMETER ADDRESS 
          ZR     X1,NOMORE         IF PARAMETER LIST EXHAUSTED
          SA3    X1                X3=PARAMETER 
          BX0    X3-X7
          NZ     X0,OK3            PARAMETER NOT EQUAL TO 2**59 
          AX3    1
OK3       BSS    0
          SA1    A1+B1             FETCH NEXT PARAMETER ADDRESS 
          ZR     X1,NOMORE         IF PARAMETER LIST EXHAUSTED
          SA4    X1                X4=PARAMETER 
          BX0    X4-X7
          NZ        X0,OK4
          AX4    1
OK4       BSS    0
          SA1    A1+B1             FETCH NEXT PARAMETER ADDRESS 
          ZR     X1,NOMORE         IF PARAMETER LIST EXHAUSTED
          SA5    X1                X5=PARAMETER 
          BX0    X5-X7
          NZ     X0,OK5            PARAMETER NOT EQUAL TO 2**59 
          AX5    1
OK5       BSS    0
          SA1    A1+B1             FETCH NEXT PARAMETER ADDRESS 
          ZR     X1,NOMORE         IF PARAMETER LIST EXHAUSTED
          SB2    A1                SAVE A1 FOR NOW
          SA1    X1 
          BX6    X1                X6=PARAMETER 
          BX0    X6-X7
          NZ     X0,OK6            PARAMETER NO TEQUAL TO 2**59 
          AX6    1
OK6       BSS    0
          SA1    B2+B1             FETCH NEXT PARAMETER ADDRESS 
          ZR     X1,NOMORE         IF PARAMETER LIST EXHAUSTED
          BX0    X1-X7
          NZ     X0,OK7            PARAMETER NOT EQUAL TO 2**59 
          AX1    1
OK7       BSS    0
          BX7    X1                X7=ADDRESS 
* 
* 
*         PART TWO
* 
*         IT IS NOW TIME TO DECIDE WHERE WE WERE CALLED FROM AND DO THE 
*         NECESSARY REGISTER EXCHANGING IN PREPARATION FOR THE MACRO CALL.
* 
* 
NOMORE    BSS    0                 PARAMETER FETCHING FINISHED
          JP     B5+JUMPTAB        JUMP TO EXCHANGE AREA THRU JUMPTAB 
* 
*         THIS IS THE JUMP TABLE USED TO GET TO THE PROPER AREA FOR 
*         EXCHANGING.  NOTE THAT GETP AND PUTP HAVE THE SAME JUMP 
*         DESTINATIONS, AS DO PUT AND REPLACE.
* 
* 
JUMPTAB   BSS    0                 JUMP TABLE AREA
+         EQ     S.PUT
+         EQ     S.GET
+         EQ     S.GETN 
+         EQ     S.GETP 
+         EQ     S.DELETE 
+         EQ     S.SEEK 
+         EQ     S.PUTP 
+         EQ     SETTEMP           SKIPBL/SKIPFL
+         EQ     S.START
* 
* 
S.PUT     BSS    0                 PUT OR REPLACE 
          EX     X4,X7
          EX     X5,X7
          EX     X6,X7
          EQ     POS
S.GET     BSS    0                 GET
          EX     X3,X6             X3=RL
          EX     X4,X7             X4=EX/DX 
          EX     X5,X6             X5=WA/KEY
          EX     X6,X7             X6=KP    ,    X7=MKL 
          EQ     SETTEMP
S.GETN    BSS    0                 GETN 
          EX        X3,X5 
          EQ     SETTEMP
S.GETP    BSS    0                 GETP AND PUTP
          EX     X4,X7             X7=SKP 
          EX     X4,X5             X4=DX
          EX     X3,X5             X5=PTL 
          SA1       =4LSKIP 
          EQ        S.GPPP
S.DELETE  BSS    0                 DELETE 
S.SEEK    BSS    0                 SEEK 
          EX        X4,X5 
          EX        X5,X2 
          EX        X6,X3 
          EX        X7,X2 
          SB2    B5-4              DELETE 
          NE     B2,B0,SETTEMP     JUMP IF SEEK 
 POS      BSS    0                 STORE POS PARAMETER (PUT,REPL,DLT) 
          MX1    1
          BX1    -X1*X7 
          NZ     X1,POSVAL
          SX7    0                 NO USER-SPEC POS -- CLEAR POS IN FIT 
          EQ     SETTEMP
 POSVAL   BSS    0
          SB2    6
          LX0    B2,X7
          SX7    1                 IF POS=C,N 
          SX0    X0-20B 
          NG     X0,SETTEMP 
          SX7    40B               IF POS=P 
          EQ     SETTEMP
 S.PUTP   BSS       0 
          EX     X3,X4             X3=RL
          EX     X4,X5             X4=EX
          EX     X7,X6             X6=PTL , X7=TRM
          SA1       =4LTERM 
 S.GPPP   BSS       0 
          MX0       24
          BX7       X0*X7 
          IX0       X7-X1 
          MX7       1 
          NZ        X0,S.NOPAR
          SX7       B1
 S.NOPAR  BSS       0 
          MX0    0
          SETBIT 18 
          EQ     SETTEMB
 S.START  BSS    0
          EX        X7,X4 
          EX        X6,X3 
          EX        X5,X2 
          EX        X4,X2 
SETTEMP   BSS    0
* 
* 
* 
*         PART THREE
* 
*         WE WILL NOW SET THE PROPER BITS INDICATING REGISTER USAGE 
*         IN TEMP, WHICH WILL THEN BE USED BY THE CALLING ROUTINE.
* 
* 
*#
* 
*         THE REGISTER USAGE WORD IS ALWAYS THE LAST WORD IN THE
*         APPROPRIATE CRM MACRO EXPANSION.  ITS FIELDS ARE AS FOLLOWS 
*             59-30  A JUMP INSTRUCTION AS ASSEMBLED WITHIN THE MACRO 
*                  (THIS INSTRUCTION MUST BE PRESERVED BY THE CALLER
*                    TO STUFF BEFORE HE MAKES THE MACRO CALL) 
*                29  =1 ONLY IF B5 CONTAINS A PARAMETER FOR CRM MACRO 
*                28  =1 ONLY IF B3 CONTAINS A PARAMETER FOR CRM MACRO 
*                27  =1 ONLY IF X6 CONTAINS A PARAMETER FOR CRM MACRO 
*                26  =1 ONLY IF B2 CONTAINS A PARAMETER FOR CRM MACRO 
*                25  =1 ONLY IF X3 CONTAINS A PARAMETER FOR CRM MACRO 
*                24  =1 ONLY IF X2 CONTAINS A PARAMETER FOR CRM MACRO 
*             23-18  SPECIFIES ANY SPECIAL TYPE OF OPERATION
*                    =1  FOR PARTIALS 
*                    =0 OTHERWISE 
*             17-00  ALWAYS EQUAL TO ZERO 
* 
* 
*#
          MX0    0
SETTEMB   BSS    0
          CHKBIT X2,24
          CHKBIT X3,25
          CHKBIT X4,26
          CHKBIT X5,27
          CHKBIT X6,28
          CHKBIT X7,29
          MX1       30
          BX2       -X1*X2         MASK WSA FOR FTN5
          SB2       X4
          SB5    X7 
          SB3    X6 
          BX6       X5
          EQ     RM$STUF           OUT OF HERE
          END 
          IDENT  RMKDEF 
          COMMENT   CRM FTN INTERFACE (RMKDEF)
          ENTRY  RMKDEF,RM$KDPT,RM$KDWS 
          SPACE  1
*#
* D01                        RMKDEF PROCEDURE 
* D0      PURPOSE 
*                PROCESS A RMKDEF PARAMETER LIST AND PUT KEYDEF 
*                INTO INDEX FILE. 
* D0      INPUT:  
*                REGISTER A1= LOCATION OF PARAMETER LIST. 
* D0      PARAMETERS: 
*                P1 - FIT    LFN OF FIT.
*                P2 - RKW    WORD DISPLACEMENT OF ALTKEY IN RECORD. 
*                P3 - RKP    CHARACTER DISPLACEMENT OF ALTKEY IN RECORD.
*                P4 - KL     ALTKEY LENGTH IN CHARACTERS. 
*                P5 - KI      KEY INDEX ID (UNCONDITIONALLY SET TO ZERO)
*                P6 - KT     ALTKEY TYPE (DEFAULT= SYMBOLIC)
*                P7 - KS     ALTKEY STRUCTURE (DEFAULT= UNIQUE).
*                P8 - KG     REPEATING GROUP SIZE (DEFAULT= ZERO).
*                P9 - KC     OCCURANCES OF KEY IN GROUP.
*                P10- NL      1LN = NULL SUPPRESSION        (SPARSE KEY)
*                P11- IE      1LI = INCLUDE, 1LE = EXCLUDE  (SPARSE KEY)
*                P12- CH      STRING OF CODES THAT DETERMINE PRESENCE OF
*                             ALTERNATE KEY VALUE IN INDEX  (SPARSE KEY)
* D0      OUTPUT: 
*                NONE.
* D0      CALLING ROUTINES: 
*                USER CALLED. 
* D0      ROUTINES CALLED:  
*                AAM$GO 
* D0      LOGIC:  
*                BUILD THE RMKDEF WORDS FROM INPUT
*                PARAMETERS, THEN CALLS AAM$INF TO PUT KEYDEF IN
*                 INDEX FILE. 
* D0      ENTRY POINT USAGE:  
*                RMKDEF       FORTRAN OBJECT TIME 
*                             MIPGEN
*                RM$KDPT      COMPASS OBJECT TIME 
*                             COBOL OBJECT TIME 
*                RM$KDWS      MIPGEN
*#
          SPACE  1
 EXIT     BSS    0
          SB2    A0 
          SA2    =SAVA0 
          SA0    X2 
          SB1    1
          SA2    SAVWSA 
          STORE  B2,WSA=X2
 RMKDEF 
          SX6    A0                SAVE A0. 
          SA6    =SAVA0 
          SA0    X1          SAVE THE FIT ADDRESS 
          SA4    SIZES             DEFINES SIZE AND ORDER OF FIELDS 
          MX0    54 
          SX6    B0 
          SB5    60                USED FOR SHIFTING PARAMETER VALUES.
          SA6    RM$KDWS+1         INITIALIZE WORD 2 OF KEYDEF
          SPACE  1
 DBWLOOP  LX4    6                 LENGTH OF NEXT KEYDEF FIELD
          BX5    -X0*X4 
          ZR     X5,SPK            IF SPARSE KEY OPTIONS NEXT 
          BX5    -X5
          SB5    B5+X5             SHIFT-CONSTANT FOR NEXT PARAMETER. 
          SB2    B5-30D 
          EQ     B2,B0,DBWLOOP     IF UNUSED FIELD
          SA1    A1+1              LOAD NEXT ADDRESS IN PARAM-LIST. 
          ZR     X1,RM$MDBW        FINISHED IF PARAMETER ADDRESS = ZERO.
          SB2    B5-29D 
          EQ     B2,B0,DBWLOOP     IF KI, ALWAYS ZERO 
          SA2    X1                PARAMETER VALUE. 
          MX5    6
          BX3    X5*X2
          LX3    6
          SB2    B5-27D 
          NE     B2,B0,CKS         IF NOT KF, GO CHECK FOR KS 
          ZR     X3,DBWMERG       IF KF IS IN INTEGER FORM, NOT SYMBOLIC
          SB3    X3-1RS 
          MX2    0
          ZR     B3,DBWMERG        IF KF=SYMBOLIC 
          SB3    X3-1RI 
          SX2    1
          ZR     B3,DBWMERG        IF KD=INTEGER
          SB3    X3-1RU 
          SX2    2
          ZR     B3,DBWMERG        IF KF = UNSIGNED 
          SX2    3                 KF=PURGE 
          EQ     DBWMERG
          SPACE  1
 CKS      BSS    0
          SB2    B5-24D 
          NE     B2,B0,DBWMERG     JUMP IF NOT KS PARAMETER 
          ZR     X2,DBWLOOP        IF KS=0, DEFAULT=0 
          SB3    X3-1RU 
          EQ     B3,B0,DBWLOOP     IF UNIQUE, DEFAULT=0 
          SB3    X3-1RF 
          SX2    7
          EQ     B3,B0,DBWMERG     IF KS=FIFO 
          SX2    3                 KS=IS
 DBWMERG  LX2    B5,X2             MERGE PARAMETER VALUE TO KEYDEF WORD.
          BX6    X6+X2
          SA6    RM$KDWS           STORE WORD 1 OF KEYDEF 
          EQ     DBWLOOP
          SPACE  1
 SPK      BSS    0
*                                  IF NL=1LN SET SIGN BIT=1 
          SA5    A1+1 
          SX4    1RN
          LX4    54 
          SA3    X5 
          IX0    X3-X4
          ZR     X5,RM$MDBW 
          NZ     X0,.GL1
          MX7    1
          SA7    RM$KDWS+1
*                                  SAVE IE ADDRESS IN X2 AND INITIALIZE 
*                                  FOR CH SCAN. 
 .GL1     BSS    0B 
          SA2    A5+1B
          ZR     X2,RM$MDBW 
          SA5    A2+1B
          ZR     X5,.2
          MX1    1B 
          SB5    X5 
          SB6    74B
          SB4    X5+3B
 )AA      BSS    0B 
          SA5    RM$KDWS+1
          SA4    B5 
          BX7    X5 
          SB7    6B 
          BX0    X4 
*                                  EXTRACT A CHARACTER FROM CH STRING.
*                                  IF ZERO EXIT LOOP.  ELSE SET BIT 
*                                  POSITION FROM LEFT SPECIFIED BY VALUE
*                                  OF CODE TO 1.  LOOP FOR NEXT CODE. 
 )AB      BSS    0B 
          SX6    77B
          LX5    B7,X0
          BX4    X6*X5
          ZR     X4,.2
          SX6    74B
          SB7    B7+6B
          IX5    X6-X4
          SB2    X5 
          LX6    B2,X1
          BX7    X7+X6
          SA7    RM$KDWS+1
          GE     B6,B7,)AB
*                                  INCREMENT FOR NEXT WORD OF CH STRING.
          SB5    B5+1B
          GE     B4,B5,)AA
*                                  IF IE(X2) IS 1LI THEN COMPLEMENT 
*                                  WORD 2 OF KEYDEF.
 .2       BSS    0B 
          SX4    1RI
          LX4    54 
          SA3    X2 
          IX0    X3-X4
          NZ     X0,RM$MDBW 
          SA5    RM$KDWS+1
          MX0    1
          BX6    X0*X5
          BX5    -X5
          BX7    -X0*X5 
          BX7    X7+X6
          SA7    A5 
 RM$MDBW  BSS    0
          SA1    =SARG2      LOAD ADDRESS OF RMKDEF 
          EQ     KDCALL 
          SPACE  1
 RM$KDPT  EQ     *+1S17 
          SA3    RM$KDPT
          SA0    X1          SAVE THE FIT ADDRESS 
          BX6    X3 
          SA1    A1+1        LOAD ADDRESS OF RMKDEF 
          SA6    RMKDEF 
 KDCALL   BSS    0
          SB6    EXIT        CRM RETURN ADDRESS 
          SB1    1
          F.RM   FNF,2
          CRMEP  ES=115B,FNF=1,IFOP=(NG X2)  OUTSTANDING FATAL ERROR
          F.RM   OC,2 
          LX2    59 
          CRMEP  ES=110B,FNF=1,IFOP=(PL X2)  FILE NOT OPENED
          F.RM   XN,2 
          CRMEP  ES=515B,FNF=1,IFOP=(ZR X2)  NO INDEX FILE SPECIFIED
          SB4    B0 
          FETCH  A0,WSA,X2
          BX6    X2 
          SA6    SAVWSA 
          STORE  A0,WSA=A1   WSA POINTS TO PARAMETER LIST 
          EQ     =XAAM$GO    WRITE KEYDEFS TO INDEXF
 ARG2     VFD    42/0,18/RM$KDWS
 RM$KDWS  BSSZ   2
          SPACE  2
 SAVWSA   BSS    1
 SIZES    VFD    6/15D,6/4,6/8,6/3,6/1,6/2,6/3,6/12,6/12,6/0
*FIELD             RKW,RKP, KL, --, KI, KF, KS,  KG,  KC, --
          END 
          IDENT     FITDMP
          ENTRY     FITDMP
          ENTRY     FITD$RM 
          COMMENT   CRM FTN INTERFACE (FITDMP)
          EXT       ERR$RM         FORCE HARD EXTERNAL
          B1=1
          SST 
* CALL /EPCOM/
*CALL /EPCOM/ 
          EJECT 
 #EFCN#   MICRO     1,,/0,15B,1,55,2,1/ NOTES TO ERROR FILE 
 EFC      COMPOSED  EFCN,1,EXD,1        DIAGNOSE TEXT CHANGE
 A0TMP    DATA      0 
 RETURN   BSS       0 
          SA1       A0TMP          RESTORE FTN APLIST 
          SA0       X1+0
 FITD$RM  BSS       0 
 FITDMP   EQ        *+1S17         ENTRY / EXIT 
          SB6       RETURN
          SX6       A0
          SA6       A0TMP          SAVE FTN APLIST
          RJ        =XPLST$RM 
          SA0       X1             (FIT)
          SA2       FIT            SECOND INSERT (FIT)
          SB1       1 
          MX0       LOC.S 
          LX0       60-LOC.P
          BX3       -X0*X2         CLEAR FIT LOCATION FIELD 
          BX1       X0*X1          CLEAR GARBAGE FROM APLIST WORD 
          MX4       FIT.S 
          LX1       60-LOC.P-LOC.S
          BX5       X3+X1          OR IN FIT ADDRESS
          LX4       60-FIT.P
          BX6       X5+X4          SET FIT DUMP FLAG
          SA1       A1+B1          (ID) 
          NZ        X1,USEID       IF ID SPECIFIED
          SX1       IDBL           ELSE USE BLANK ID
 USEID    BSS       0 
          SA3       A2-B1          FIRST INSERT (ID)
          SA6       A2             SECOND INSERT (FIT)
          MX0       LOC.S 
          LX0       60-LOC.P
          BX2       -X0*X3         CLEAR ID LOCATION FIELD
          LX1       60-LOC.P-LOC.S
          BX6       X1+X2          OR IN NEW LOCATION 
          SA6       A3             FIRST INSERT (ID)
          SET.RM    EFCN,1         TURN ON ERROR FILE NOTES 
          CRMEP     ES=1000B,INA=ID = USER FIT DUMP 
          EQ        RETURN
          SPACE     1 
 ID       CRMEI     TYPE=2,MODE=1,LOC=IDBL,LEN=1
 FIT      CRMEI     TYPE=0,MODE=1,LOC=0,LEN=#FTL#+#FTS#,EOL=1 
 IDBL     DATA      10H 
          END 
