AXR$
$(2)   LIT .
          ELT$
          .                             DESIGNED AND IMPLEMENTED
          .
          .                             BY DEREK A. ZAVE
          .
          .         THE FOLLOWING THREE PARAMETERS DEFINE THIS ROUTINE
          .
          .                   CYCLIM -  MAXIMUM NUMBER OF ELEMENT CYCLES
          .
          .                   ROFF   -  IF ROFF=1 THEN PREPRO IS GENERATED;
          .                             IF ROFF=0 THEN PREPRM IS GENERATED.
          .
          .                   TAPE   -  IF TAPE=1 THEN MAGNETIC TAPE IS A LEGAL
          .                             INPUT DEVICE.
          .
CYCLIM    EQU       5
ROFF      EQU       1
TAPE      EQU       1
          .
/         .
          .         DEFINITIONS
          .
          DO        ROFF ,PRO EQU RES
          DO        ROFF ,EPRO EQU RES
          DO        1-ROFF ,PRO EQU PROC
          DO        1-ROFF ,EPRO EQU END
          DO        TAPE ,TAPE EQU RES
          DO        TAPE ,ETAPE EQU RES
          DO        1-TAPE ,TAPE EQU PROC
          DO        1-TAPE ,ETAPE EQU END
          .
IOP       EQU       1*/('Z'-'I')        'I'-OPTION BIT
LOP       EQU       1*/('Z'-'L')        'L'-OPTION BIT
UOP       EQU       1*/('Z'-'U')        'U'-OPTION BIT
NAME      EQU       2                   RELATIVE LOCATION OF ELEMENT NAME
VER       EQU       6                   RELATIVE LOCATION OF ELEMENT VERSION
CYC       EQU       8                   RELATIVE LOCATION OF CYCLE WORD
INFORS    EQU       27*((1+20*(2+ROFF))//27) SIZE RESERVED FOR INFOR TABLE
F         FORM      12,6,18             A USEFUL FORM
          .
PCW*      PROC      1,1               . GENERATE A PRINT$ CONTROL WORD
          F         1,$-PCW(1,1),PCW(1,1)
          END
          .
SIF       EQU       PARTBL+1            SOURCE INPUT FIELD LOCATION
SIFN      EQU       1                   SOURCE INPUT FIELD NUMBER
SIFC      EQUF      PARTBL+13,,S1       SOURCE INPUT FILE CODE
          PRO
ROF       EQU       PARTBL+27           RELOCATABLE OUTPUT FIELD LOCATION
ROFN      EQU       2                   RELOCATABLE OUTPUT FIELD NUMBER
ROFC      EQUF      PARTBL+13,,S3       RELOCATABLE OUTPUT FILE CODE
          EPRO
SOF       EQU       PARTBL+14           SOURCE OUTPUT FIELD LOCATION
SOFN      EQU       2+ROFF              SOURCE OUTPUT FIELD NUMBER
SOFC      EQUF      PARTBL+13,,S2       SOURCE OUTPUT FILE CODE
          .
/         .
          .         ASSORTED DATA
TPF$      'TPF$  '
BLANK     '            '
EF        .
          DO        TAPE , '**EF**'
          +         0
          .
LODFC     LA,U      A0,0                VECTOR TO LOAD THE DEVICE CODE
          LA        A0,SIFC
          DO        ROFF , LA A0,ROFC
          LA        A0,SOFC
          .
STFC      SA        A1,SIFC             VECTOR TO STORE THE DEVICE CODE
          DO        ROFF , SA A1,ROFC
          SA        A1,SOFC
          .
LODFN     DL        A1,TPF$             VECTOR TO LOAD THE FILE NAME
          DL        A1,SIF
          DO        ROFF , DL A1,ROF
          DL        A1,SOF
          .
FREOPT    'A     '                      @FREE OPTIONS
          'AX    '
          'AR    '
SAVX8     EQUF      $,,H1               SAVE AREA FOR X8
SAVX9     EQUF      $,,H2               SAVE AREA FOR X9
          +         0,0
SAVX10    EQUF      $,,H1               SAVE AREA FOR X10
SAVX11    EQUF      $,,H2               SAVE AREA FOR X11
          +         0,0
          .
CONT      +         EF+TAPE             FILE CONTINUATION TABLE
          DO        2+ROFF , +0
          .
CYCLE     +         0                   CYCLE INFORMATION
          .
FREE      '@FREE,OPTION'                @FREE IMAGE
FREEF     +         0D
          .
          TAPE
TPKT      EQU       $-2                 PACKET TO READ THE LABEL BLOCK
          +         0
          +         SCR$,0,0
          +         2,ACW
          .
ACW       +         CYC+2,TBUF          ACCESS CONTROL WORDS
          +         0200000+28-CYC,TBUF+4
          ETAPE
          .
ASG       '@ASG,AX     '                @ASG IMAGE
TBUF      .                             TAPE INPUT BUFFER
FILE      RES       10                  AND FACIL$ PACKET
          DO        10<CYC+2 , RES CYC-8
          .
INFOR     RES       INFORS+1            INFOR TABLE AREA
          .
          DO ROFF ,PREINF* EQU INFOR  . *** TEMPORARY - FOR COLLECTOR LEVEL < 17
/         .
          .         ROUTINE ENTRANCE
          DO        ROFF ,PREPRO*     . PREPRO ENTRANCE
          DO        1-ROFF ,PREPRM*   . PREPRM ENTRANCE
          SX        X11,SAVX11          SAVE X11
          SX        X10,SAVX10          SAVE X10
          SX        X9,SAVX9            SAVE X9
          SX        X8,SAVX8            SAVE X8
          LA        A0,(INFORS+1,INFOR) A0 = INFOR BUFFER DESCRIPTION
          LMJ       X11,RINF$           READ THE INFOR TABLE
          J         ERR                 ERROR - PROCESS IT
          LA        A0,INFOR            A0 = OPTION BITS
          SA        A0,PARTBL           STORE THEM
          SZ,S1     PARTBL              CLEAR THE DEVICE CODE
          LA,U      A1,0                A1 = 0
          TEP,U     A0,IOP              'I'-OPTION ?
          AA,U      A1,1                YES, SET A BIT
          TEP,U     A0,UOP              'U'-OPTION ?
          AA,U      A1,2                YES, SET ANOTHER BIT
          LA        A0,PEM1             A0 = CONFLICT MESSAGE DESCRIPTION
          J         $+1,A1              BRANCH ON A1
          J         PREPN               0 - NO OPTIONS
          J         PREPI               1 - 'I'-OPTION
          J         PREPU               2 - 'U'-OPTION
          J         ERR                 3 - 'I'-OPTION AND 'U'-OPTION - ERROR
          .
/         .
          .         NO OPTIONS
          .
PREPN     LMJ       X10,GSI             GET THE SOURCE INPUT FIELD
          J         PREPN1              NOT SPECIFIED
          DO        ROFF , LMJ X10,GRO  GET THE R.O. FIELD
          LXM,U     X9,GSO+1            X9 = S.O. DESCRIPTION LOCATION
          LA,U      A0,SOFN             A0 = FIELD NUMBER
          LMJ       X11,SELT$           LOOK FOR THE FIELD
          DO        ROFF , J PREPU1     NO FIND - FINISH UP
          DO        1-ROFF , J PREPN2
          LMJ       X10,FLDA            PICK UP THE FIELD
         LA,U      A0,CYCLIM
         SA,S2     A0,CYC+SOF
          J         PREPU1              FINISH UP
PREPN1    LA        A0,PARTBL           A0 = OPTION BITS
          OR,U      A0,IOP+(1-ROFF)*LOP SET THE 'I'-OPTION (AND 'L' IF PREPRM)
          SA        A1,PARTBL           STORE THE RESULT
          DO        ROFF , J PREPI2     FINISH UP
          DO        1-ROFF , J PREPI1-1
          DO        ROFF , PROC
PREPN2    LA        A0,PARTBL           A0 = OPTION BITS
          OR,U      A0,LOP              SET THE 'L'-OPTION
          SA        A1,PARTBL           STORE THE RESULT
          J         PREPU1              FINISH UP
          DO        1 , PROC
          END
          .
/         .
          .         'I'-OPTION
          .
PREPI     LMJ       X10,GSISO           GET THE SOURCE INPUT FIELD
          DO        ROFF , J PREPI2     NOT GIVEN - BYPASS
          DO        1-ROFF , J PREPI1-1
          DO        ROFF , LMJ X10,GRO  GET THE RELOCATABLE OUTPUT FIELD
          LA,U      A0,CYCLIM           A0 = STANDARD CYCLE MAXIMUM
          SA,S2     A0,CYC+SOF          STORE IT
PREPI1    TNZ       SOF                 IS THERE SOURCE OUTPUT ?
          J         EXIT                NO, EXIT
          LA,U      A0,SOF              A0 = LOCATION OF FILE NAME
          ER        PFWL$               GET THE NEXT WRITE LOCATION
          LA        A0,PEM2             A0 = ERROR MESSAGE DESCRIPTION
          JNZ       A2,ERRA             NO LUCK - PROCESS THE ERROR
          SA        A1,SOF+12           STORE THE WRITE LOCATION
          LA,U      A0,1                A0 = SYMBOLIC ELEMENT TYPE
          SA,S3     A0,SOF+5            STORE IT
          J         EXIT                EXIT
          PRO
PREPI2    LMJ       X10,GROR            GET THE RELOCATABLE OUTPUT FIELD
          J         PREPI3              NOT GIVEN - SKIP
          J         PREPI1-1            FINISH UP
PREPI3    DL        A0,TPF$             A0,A1 = 'TPF$'
          DS        A0,ROF              STORE THE FILE NAME
          DL        A0,('NAME$       ') A0,A1 = 'NAME$'
          DS        A0,NAME+ROF         STORE THE ELEMENT NAME
          DL        A0,BLANK            A0,A1 = BLANKS
          DS        A0,VER+ROF          STORE THE VERSION
          J         PREPI1-1            FINISH UP
          EPRO
          .
/         .
          .         'U'-OPTION
          .
PREPU     LMJ       X10,GSI             GET THE S.I. FIELD
          J         PREPU4              NOT GIVEN - ERROR
          DO        ROFF , LMJ X10,GRO  GET THE R.O. FIELD
          LMJ       X10,GSO             GET THE S.O. FIELD
PREPU1    LA,U      A0,'*'              A0 = SOURCE INPUT TYPE
          TAPE
          LA        A1,SIFC             A1 = SOURCE INPUT DEVICE CODE
          TEP,U     A1,020              IS IT TAPE ?
          LA,U      A0,'"'              YES
          ETAPE
          SA,S1     A0,PARTBL           STORE THE TYPE
          TAPE
          TE,U      A0,'*'              INPUT FROM FASTRAND ?
          J         PREPU5              NO, READ THE LABEL BLOCK
          ETAPE
          LA,U      A0,1                A0 = SYMBOLIC TYPE
          SA,H1     A0,SIF+5            STORE IT
          LA,U      A0,SIF              A0 = PACKET LOCATION
          ER        PFS$                LOOK FOR THE ELEMENT
          LA        A0,PEM3             A0 = NO FIND MESSAGE DESCRIPTION
          JNZ       A2,ERR              NO FIND - PROCESS THE ERROR
PREPU2    LA        A0,PEM6             A0 = CYCLE ERROR MESSAGE DESCRIPTION
          LA,S5     A3,CYCLE            A3 = CYCLE SIGNAL CHARACTER
          TNE,U     A3,'E'              WAS THE CYCLE IN ERROR ?
          J         ERR                 YES
          LA,S4     A1,CYC+SIF          A1 = LATEST CYCLE
          ANU,S6    A1,CYC+SIF          A2 = OLDEST CYCLE-1
          TNE,U     A3,0                IS THE CYCLE ABSOLUTE ?
          LA,S6     A1,CYCLE            YES, A1 = CODED CYCLE
          TNE,U     A3,'-'              RELATIVE BACKWARDS ?
          ANA,S6    A1,CYCLE            YES, SUBTRACT THE OFFSET
          TE,U      A3,'+'              RELATIVE FORWARDS ?
          J         PREPU3              NO, BYPASS
          LA,XU     A1,1,A2             A1 = OLDEST CYCLE
          AA,S6     A1,CYCLE            ADD THE OFFSET
PREPU3    LA,S4     A3,CYC+SIF          A3 = LATEST CYCLE
          TW        A2,A1               DOES THE CYCLE EXIST ?
          J         ERR                 NO, ERROR
          SA,S6     A1,PARTBL+13        STORE THE REQUESTED CYCLE
          J         PREPI1              FINISH UP
PREPU4    LA        A0,PEM7             A0 = ERROR MESSAGE DESCRIPTION
          J         ERR                 PROCESS THE ERROR
          TAPE
PREPU5    DL        A0,SIF              A0,A1 = INPUT FILE NAME
          DS        A0,TPKT             STORE IT
          LA,U      A0,TPKT             A0 = I/O PACKET LOCATION
          ER        IOW$                READ THE LABEL BLOCK
          LA,S1     A0,TPKT+3
          JZ        A0,PREPU6           IT'S O.K. - BYPASS
          DSL       A0,3                EDIT IT TO OCTAL
          SSL       A1,33
          LSSL      A0,6
          AA,U      A0,' 00',A1
          SA,H1     A0,IOSTAT           STORE THE RESULT
          LA        A0,PEM5             A0 = I/O ERROR MESSAGE DESCRIPTION
          J         ERR                 PROCESS THE ERROR
PREPU6    LA        A0,PEM4             A0 = LABEL BLOCK MESSAGE DESCRIPTION
          DL        A1,TBUF             A1,A2 = FIRST TWO WORDS OF THE BLOCK
          LA,H2     A3,TPKT+3           A3 = NUMBER OF WORDS READ
          TNE,U     A3,28               IS THE BLOCK THE RIGHT SIZE ?
          DTE       A1,EF               AND IS IT A LABEL BLOCK ?
          J         ERR                 NO, ERROR
          LA,H1     A3,TBUF+5           A3 = TYPE BITS
          AND,U     A3,077              A4 = ELEMENT TYPE
          DL        A1,NAME+TBUF        A1,A2 = ELEMENT NAME
          TLE,U     A4,5                IS THE TYPE IN RANGE ?
          DTE       A1,NAME+SIF         AND DO THE NAMES MATCH ?
          J         ERR                 NO, ERROR
          DL        A1,VER+TBUF         A1,A2 = ELEMENT VERSION
          TE,U      A4,0                IS THE TYPE NONZERO ?
          DTE       A1,VER+SIF          AND DO THE VERSIONS MATCH ?
          J         ERR                 NO, ERROR
          SA,H1     A3,SIF+5            STORE THE TYPE
          DL        A0,CYC+TBUF         A0 = CYCLE WORD, A1 = SYMBOLIC TYPE
          DS        A0,CYC+SIF          STORE THEM
          J         PREPU2              FINISH UP
          ETAPE
          .
/         .
          .         PICK UP SOURCE INPUT FOR UPDATE
          .
          .         THE FOLLOWING IS A SUCCESSION OF CALLS ON THE ROUTINE  FLD
          .         WITH THE SIXTHS OF THE FIRST PARAMETER WORD DEFINED AS:
          .
          .                   S1 - INFOR FIELD NUMBER
          .                   S2 - ERROR MASK - BIT 5 = WRITE INHIBITED
          .                                     BIT 4 = TAPE
          .                   S3 - FIELD-IS-REQUIRED FLAG (NAME MUST BE THERE)
          .                   S4 - CYCLE
          .                   S5 - ILLEGAL-FIELD FLAG
          .                   S6 - PARTBL FIELD NUMBER - 1 = SO, 2 = RO, 3 = SO
          .
          .
GSI       LMJ       X9,FLD
          +         SIFN,0,1,1,0,SIFN
          F         'SI',,SIF
          .
          .         PICK UP THE SOURCE INPUT FOR 'I'-OPTION
          .
GSISO     LMJ       X9,FLD
          +         SIFN,060,1,0,0,SOFN
          F         'SI',,SOF
          .
          .         PICK UP THE RELOCATABLE OUTPUT FIELD
          .
          PRO
GRO       LMJ       X9,FLD
          +         ROFN,060,0,0,0,ROFN
          F         'RO',,ROF
          .
          .         PICK UP REQUIRED RELOCATABLE OUTPUT FIELD
          .
GROR      LMJ       X9,FLD
          +         ROFN,060,1,0,0,ROFN
          F         'RO',,ROF
          EPRO
          .
          .         PICK UP SOURCE OUTPUT FIELD
          .
GSO       LMJ       X9,FLD
          +         SOFN,060,0,0,0,SOFN
          F         'SO',,SOF
          .
          .         CHECK FOR ILLEGAL SOURCE OUTPUT FIELD
          .
GSOE      LMJ       X9,FLD
          +         SOFN,0,1,0,1,0
          F         'SO',,0
          .
/         .
          .         PROCESS A FIELD
          .
FLD       LA,S1     A0,,X9              A0 = FIELD NUMBER
          TE,U     A0,2               RELOCATABLE
          J        FLDAA              NO
          L,S5     A1,PARTBL          OPTION LETTERS
          SSL      A1,2               R OPTION INTO LOW BIT
          JB       A1,0,X10           RETURN
FLDAA  .
          SX,H2     X9,CONT,A0          SAVE THE ITEM LOCATION
          LXM,S3    X8,,X9              X8 = DON'T FILL FLAG
          LMJ       X11,SELT$           LOOK FOR THE FIELD
          JMGI      X8,,X10             NO FIND - RETURN IF NO FILL
FLDA      TZ,S3     0,X9                ARE WE EXPECTED TO FILL ?
          LXM,U     X10,1,X10           NO, ADJUST THE RETURN POINT
          LXM,S6    X8,,X9              X8 = DEVICE CODE INDEX
          LA        A0,PEM8             A0 = ILLEGAL FIELD MESSAGE DESCRIPTION
          TZ,S5     0,X9                IS THE FIELD ILLEGAL ?
          J         ERRA                YES, PROCESS THE ERROR
          TZ,S3     0,X9                FILL REQUESTED ?
          TZ        ENL                 OR WAS THE NAME GIVEN ?
          J         FLD1                YES, BYPASS
          LA        A0,PEM9             A0 = ERROR MESSAGE DESCRIPTION
          J         ERRA                PROCESS THE ERROR
FLD1      LA        A0,CFN              A0 = CONTINUATION FIELD NUMBER
          JNZ       A0,FLD2             FILE CONTINUATION - BYPASS
          TZ        ELT$                ANY FILE INFORMATION ?
          J         FLD3                YES, BYPASS
          TNZ       ENL                 FILLING REQUESTED ?
          LA,U      A0,1                YES, FUDGE
FLD2      LA,S6     A3,*CONT,A0         A3 = FIELD CODE
          EX        LODFN,A3            A1,A2 = ATTACHED NAME
          TNZ       A1                  IS IT ZERO ?
          DL        A1,TPF$             YES, ASSUME TPF$
          DS        A1,*1,X9            STORE IT
          EX        LODFC,A3            GET THE DEVICE CODE
          AND,U     A0,060              CLEAR THE @FREE OPTIONS
          J         FLD10               BYPASS
FLD3      LXI,H1    A0,1,X9             BUILD THE FILE NAME
          AA        A0,('$   ')
          LA        A1,BLANK            BLANK FILL TO TWO WORDS
          DS        A0,FILE             STORE IT INTO THE @ASG IMAGE
          DS        A0,*1,X9            STORE IT INTO PARTBL
          LMJ       X11,DUSE$           PERFORM A DYNAMIC @USE
          JN        A0,FLD4+1           BAD STATUS - PROCESS IT
          LA,U      A1,1                A1 = 1 (CODE TO FREE ATTACHED NAME)
          LA,U      A0,FILE             A0 = FACIL$ PACKET LOCATION
          ER        FACIL$              GET THE FACILITY DESCRIPTION
         DL    A4,FILE+2
         TNE   A4,('TPF$  ')
         DS    A4,*1,X9
          LA,H1     A2,FILE+6           A2 = SOME IMPORTANT BITS
          TG,U      A2,1*/12            NO DEVICE ?
          TOP,U     A2,1*/(29-18)       OR NO EXCLUSIVE USE ?
          J         $+2
          J         FLD7                NO, BYPASS
          LA,U      A0,ASG              A0 = @ASG IMAGE LOCATION
          ER        CSF$                GET WHAT WE WANT
          JP        A0,FLD6             GOOD STATUS - BYPASS
FLD4      EX        STFC-1,X8           STORE THE FREE OPTION CODE
          LR,U      R1,11               EDIT THE STATUS TO OCTAL
          LR,XU     R2,-7
          DL        A1,('000000000000')
FLD5      MLU       A0,A1
          SSL       A0,3
          DSC       A1,6
          JGD       R1,FLD5
          DSC       A1,36               A1,A2 = RESULT
          DS        A1,STATUS           STORE IT
          LA        A0,PEM10            A0 = ERROR MESSAGE DESCRIPTION
          J         ERRA                PROCESS THE ERROR
FLD6      LA,U      A1,2                A1 = 2 (FREE EXCLUSIVE USE)
          TOP       A0,(1*/33)          DID WE ALREADY HAVE THE FILE ?
          LA,U      A1,3                NO, A1 = 3 (FREE THE DEVICE)
          LA,U      A0,FILE             A0 = LOCATION OF FACIL$ PACKET
          ER        FACIL$              GET THE FACILITY DESCRIPTION
          LA,H1     A2,FILE+6           A2 = SOME IMPORTANT BITS
FLD7      EX        STFC-1,X8           STORE THE FREE CODE
          TAPE
          TLE,U     A2,020*/12          IS THE DEVICE TAPE ?
          TLE,U     A2,1*/12
          J         FLD8                NO, BYPASS
          AA,U      A1,020              YES, SET THE FLAG
          J         FLD9                BYPASS
          ETAPE
FLD8      LA        A0,PEM11            A0 = DEVICE ERROR MESSAGE DESCRIPTION
          TLE,U     A2,040*/12       . IS FILE FASTRAND FORMAT
          TLE,U     A2,030*/12
          J         ERRA                NO, ERROR
FLD9      LA        A0,PEM12            A0 = READ ERROR MESSAGE DESCRIPTION
          TEP,U     A2,1*/(25-18)       CAN WE READ THE FILE ?
          J         ERRA                NO, ERROR
          TEP,U     A2,1*/(26-18)       CAN WE WRITE INTO THE FILE
          AA,U      A1,040              NO, SET THE BIT
FLD10     AND,S2    A1,,X9              LOOK FOR AN ERROR
          LA        A0,PEM13            A0 = READ ONLY MESSAGE DESCRIPTION
          TAPE
          TEP,U     A2,020              ILLEGAL OUTPUT DEVICE ?
          LA        A0,PEM14            YES, A0 = MESSAGE DESCRIPTION
          ETAPE
          JNZ       A2,ERRA             PROCESS THE ERROR
          EX        STFC-1,X8           STORE THE FREE CODE
          LA        A3,CONT+SIFN        A3 = LOCATION OF S.I. DESCRIPTION
          LA,H2     A3,1,A3             A3 = LOCATION OF S.I. IN PARTBL
          LXM,H2    X8,1,X9             X8 = FIELD LOCATION IN PARTBL
          DL        A0,ENAME            A0,A1 = ELEMENT NAME
          TNZ       ENL                 WAS ONE GIVEN ?
          DL        A0,NAME,A3          NO, GET IT FROM THE S.I. FIELD
          DS        A0,NAME,X8          STORE THE ELEMENT NAME
          DL        A0,BLANK            A0,A1 = BLANKS
          TNZ       EVL                 WAS A VERSION GIVEN ?
          J         FLD11               NO
          DL        A0,EVER             A0,A1 = VERSION
          J         FLD12               BYPASS
FLD11     TNZ       ENL                 FILLING ?
          DL        A0,VER,A3           YES, GET THE VERSION FROM THE S.I.
FLD12     DS        A0,VER,X8           STORE THE VERSION
          LA        A0,ELT$+1           A0,A1 = CYCLE INFORMATION
          TZ,S4     0,X9                DO WE WANT IT ?
          SA        A0,CYCLE            YES
          TZ        ECL                 WAS A CYCLE NOT CODED ?
          TZ,S4     0,X9                OR DID WE WANT ONE ?
          J         0,X10               YES, RETURN
          LA        A0,PEM15            A0 = EXTRA CYCLE MESSAGE DESCRIPTION
          LMJ       X11,PEM             PRINT THE MESSAGE
          J         0,X10               RETURN
          .
/         .
          .         ERROR MESSAGES
          .
EM1       'I/U-OPTION CONFLICT'
PEM1      PCW       EM1
EM2       'XXX NOT A PROGRAM FILE'
PEM2      PCW       EM2
EM3       'SI: ELEMENT NOT FOUND'
PEM3      PCW       EM3
          .
          TAPE
EM4       'SI: IMPROPER LABEL BLOCK'
PEM4      PCW       EM4
EM5       'SI: TAPE I/O ERROR - STATUS:'
IOSTAT    +         0,'   '
PEM5      PCW       EM5
          ETAPE
EM6       'SI: CYCLE NONEXISTANT OR IN ERROR'
PEM6      PCW       EM6
          .
EM7       'SI: MISSING FIELD'
PEM7      PCW       EM7
EM8       'XXX ILLEGAL FIELD'
PEM8      PCW       EM8
          .
EM9       'XXX BADLY CODED FIELD'
PEM9      PCW       EM9
          .
EM10      'XXX FILE NOT FOUND - STATUS:'
STATUS    +         0D
PEM10     PCW       EM10
          .
EM11      'XXX ILLEGAL DEVICE'
PEM11     PCW       EM11
          .
EM12      'XXX FILE CAN NOT BE READ'
PEM12     PCW       EM12
          .
EM13      'XXX READ ONLY OUTPUT FILE'
PEM13     PCW       EM13
          .
          TAPE
EM14      'XXX OUTPUT FILE IS TAPE'
PEM14     PCW       EM14
          ETAPE
          .
EM15      'XXX CYCLE SPECIFICATION IGNORED'
PEM15     PCW       EM15
          .
/         .
          .         EXITS
ERRA      LX,U      X11,ERR+1           FUDGE A RETURN POINT
          .
PEM       LA,H1     A1,1,X9             A1 = FIELD NAME
          AA,U      A1,':'              INSERT A ':'
          SA,H1     A1,,A0              STORE THE RESULT
          ER        PRINT$              PRINT THE MESSAGE
          J         0,X11               RETURN
          .
ERR       ER        PRINT$              PRINT THE ERROR MESSAGE
          LA        A3,(1,1)            A3 = INDEX FOR FREES
          LR,U      R1,1+ROFF           R1 = LOOP COUNT
ERR1      EX        LODFN,A3            GET THE FILE NAME
          DS        A1,FREEF            STORE IT
          EX        LODFC,*A3           GET THE DEVICE CODE
          AND,U     A0,3                ISOLATE THE @FREE CODE
          JZ        A1,ERR2             NO ACTION - BYPASS
          LA        A0,FREOPT-1,A1      A0 = @FREE OPTIONS
          SA        A0,FREE+1           STORE THEM
          LA,U      A0,FREE             A0 = @FREE IMAGE LOCATION
          ER        CSF$                GET RID OF THE FILE
ERR2      JGD       R1,ERR1             LOOP ON R1
          SZ,H1     PARTBL+13           CLEAR THE DEVICE CODES
          LX,U      X11,0               TAKE THE ERROR RETURN
          J         EXIT+1              SKIP
          .
EXIT      LX,U      X11,1               TAKE THE NORMAL RETURN
          AX        X11,SAVX11          X11 = RETURN POINT
          LXM       X10,SAVX10          RESTORE X10
          LXM       X9,SAVX9            RESTORE X9
          LXM       X8,SAVX8            RESTORE X8
          J         0,X11               RETURN
          .
          END