SPL,L,O,T,M 
      NAME ISAGN(3,90)  !92413-16015A 760329
! 
! 
!     SOURCE:    92413-18015    REV A 
!     RELOC:     92413-16015    REV A 
! 
! 
!   ISAGN --------- DISK VERSION-DISTRIBUTED SYSTEMS
! 
! 
!   ISAGN IS AN INTERACTIVE TABLE CONFIGURATOR FOR ISA
! 
! 
!***************************************************************
! 
!   INITIALIZATION PHASE
! 
!***************************************************************
! 
      LET SWAP BE SUBROUTINE,EXTERNAL,DIRECT
      LET NAM BE INTEGER,GLOBAL  !POINTER TO NAME STRING
      LET EXEC,XOPEN,XCLOS,WRITF BE SUBROUTINE,EXTERNAL 
      LET WSAA BE PSEUDO,DIRECT 
      LET CMCNT BE INTEGER,EXTERNAL 
      LET %PRS2,%PRS5 BE INTEGER,EXTERNAL 
      LET %PR31,%PR41 BE INTEGER,EXTERNAL 
      LET OUTLU,IDPTR BE INTEGER,GLOBAL 
      LET RMPAR,XCRET BE SUBROUTINE,EXTERNAL
      LET PR1NT,PRT1,GT0UT,CLSF1,F1LCK BE SUBROUTINE,DIRECT,EXTERNAL
      LET A1DCB,A3DCB,A2DCB BE INTEGER(144),EXTERNAL
      LET %CLU BE INTEGER(5),EXTERNAL 
      LET BUFFR BE INTEGER(60),GLOBAL  !GENERAL BUFFER
      LET INTMS BE INTEGER(16)
           INITIALIZE INTMS TO 30,"  INSTRUMENT TABLE FILE NAME ?"
      LET ENDBM BE INTEGER(12)
           INITIALIZE ENDBM TO 21,"* END ISA TABLE GEN *" 
      LET CMDIN BE SUBROUTINE,EXTERNAL
      LET STPRG BE SUBROUTINE,DIRECT
      LET READ,WRITE BE SUBROUTINE,DIRECT,GLOBAL
      LET OUTRL,C2313,C6940,CONST BE SUBROUTINE,EXTERNAL
      LET INITL,READR,CHNGE BE SUBROUTINE,EXTERNAL,DIRECT 
      LET RELSE BE SUBROUTINE,DIRECT
      LET WKTOP,WKMIN,OLDWS,LAST,FIRST,FRLST BE INTEGER,GLOBAL
      LET ASCBF(6) BE INTEGER 
      LET OLDCS BE INTEGER
      LET LOUT BE SUBROUTINE,EXTERNAL,DIRECT
      LET %NLU BE INTEGER,EXTERNAL
      LET ERR1 BE INTEGER(14) 
      INITIALIZE ERR1 TO 26,"STRING UTILITY USAGE ERROR"
      LET EMES BE INTEGER(16) 
      INITIALIZE EMES TO 30," ISAGN: ALL SEGMENTS NOT FOUND"
      LET ENDMS BE INTEGER(7) 
      INITIALIZE ENDMS TO 11," $END,ISAGN"
      LET GETWK,DIAG,STPRG BE SUBROUTINE,DIRECT 
      LET CSAC,INCS BE PSEUDO,DIRECT
      LET PUTWK BE SUBROUTINE,DIRECT
      LET ISA01 BE INTEGER(3) 
           INITIALIZE ISA01 TO "ISA01"
      LET ISA02 BE INTEGER(3) 
           INITIALIZE ISA02 TO "ISA02"
      LET ISA03 BE INTEGER(3) 
           INITIALIZE ISA03 TO "ISA03"
      LET ISA04 BE INTEGER(3) 
           INITIALIZE ISA04 TO "ISA04"
      LET ISA05 BE INTEGER(3) 
           INITIALIZE ISA05 TO "ISA05"
! 
! 
! 
! 
ISAGN:CALL RMPAR(%CLU)
! 
INIT1:IFNOT %CLU(1) THEN %CLU(1)_1
      IFNOT %CLU(2) THEN %CLU(2)_20040K 
      IFNOT %CLU(3) THEN %CLU(3)_20040K 
      %PR41_%CLU(5)      !CARTRIDGE 
      %PR31_%CLU(4)      !SECURITY CODE 
      IF (%CLU(1) AND 7400K) THEN %PRS2_2,ELSE %PRS2_1
      %PRS5_400K
      CALL XOPEN(A3DCB,%PRS5) 
      CALL F1LCK?[CALL GT0UT] 
      KEYWD_$1657K
      WHILE [IDPTR_$KEYWD] DO THRU FRSPC
      IF($(IDPTR+12)#ISA05(1)) THEN GOTO FRSPC
      IF($(IDPTR+13)#ISA05(2)) THEN GOTO FRSPC
      IF(($(IDPTR+14) AND 177400K)#ISA05(3)) THEN GOTO FRSPC
      GOTO SEG1 
FRSPC:KEYWD_KEYWD+1 
      .B._@EMES+1 
      .A._EMES(1) 
      CALL PRT1 
      CALL GT0UT    !STOP BAD LOAD
SEG1: .A._@ISA01
      CALL SWAP 
      CALL INITL
! 
!*************************************************************
! 
! GENERATE THE INSTRUMENT TABLES FOR 2313,6940,&USER DEFINED
! 
!************************************************************ 
! 
! 
! 
      .A._@ISA03
      CALL SWAP 
      CALL C2313(NAMM,ENTM,EXTM,DBLM) 
      IF NAMM=0 THEN GOTO SEG4
      .A._@ISA02
      CALL SWAP 
      CALL OUTRL(ENTM,EXTM,0,NAMM)
      CALL RELSE
SEG4: .A._@ISA04
      CALL SWAP 
      CALL C6940(NAMM,ENTM,EXTM,DBLM) 
      IF NAMM=0 THEN GOTO SEG5
      .A._@ISA02
      CALL SWAP 
      CALL OUTRL(ENTM,EXTM,0,NAMM)
      CALL RELSE
SEG5: .A._@ISA05
      CALL SWAP 
      CALL CONST(NAMM,ENTM,EXTM,DBLM) 
      .A._@ISA02
      CALL SWAP 
      CALL OUTRL(NAMM,ENTM,EXTM,DBLM) 
      CALL RELSE
! 
! 
TBL02:CALL WRITE(ENDBM) !END OF GEN MESSAGE 
      %CLU(1)_%NLU
      %PRS2_0 
      CALL XCLOS(A3DCB) 
      CALL XOPEN(A3DCB,400K)
      CALL F1LCK?[GOTO DONE]
      CALL WRITE(ENDMS) 
DONE: CALL WRITF(A1DCB,IERR,0,-1) 
      CALL F1LCK?[CALL GT0UT] 
      CALL WRITF(A2DCB,IERR,0,-1) 
      CALL F1LCK?[CALL GT0UT] 
      CALL CLSF1
      CALL XCLOS(A2DCB) 
      CALL XCLOS(A3DCB) 
      CALL EXEC(6) !TERMINATE PROGRAM 
! 
!INPUT COMMAND
! 
READ: SUBROUTINE FEXIT,DIRECT 
      STPRG(NAM)
      CALL CMDIN(BUFFR(2),ERR)
      CALL F1LCK?[CALL GT0UT] 
      BUFFR(1)_(CMCNT+1)/2   !WORD COUNT
      IF BUFFR(2)="/E" THEN FRETURN 
      WSAA(NAM)_@BUFFR
      RETURN
      END 
! 
! 
! 
! 
!WRITE A MESSAGE ROUTINE
! 
WRITE:SUBROUTINE(BUF)DIRECT,GLOBAL
      .B._@BUF+1
      .A._BUF 
      CALL PR1NT
      CALL F1LCK?[CALL GT0UT] 
      RETURN
      END 
! 
! 
! 
! 
! SUBROUTINE TO RELEASE BLOCKS OF WORK SPACE
!   BLOCK ADDRESSES ARED DEIFNED IN NAMM,ENTM,EXTM,DBLM 
! 
RELSE:SUBROUTINE DIRECT 
      CALL STPRG(NAMM)
      CALL STPRG(ENTM)
      CALL STPRG(EXTM)
      CALL STPRG(DBLM)
      RETURN
      END 
! 
! 
WSAW: PSEUDO(WSPTR) GLOBAL,DIRECT 
      IFNOT WSAWF THEN DIAG(ERR1) 
      IFNOT WSPTR THEN[GETWK(OLDXW);WSPTR,OLDWS_OLDXW;\ 
                       $OLDWS_WSAWV;X_1;GOTO WSAW5] 
      IF OLDWS=OLDCS THEN OLDWS_0 
      IF WSPTR=OLDWS THEN[Y_OLDXW AND 77770K;Z_OLDXW AND 7K;GOTO WSAW3] 
      OLDWS,Y_WSPTR 
      WHILE[Z_$(Y+7)]DO Y_Z 
      UNTIL $([OLDXW_Y+Z])=100000K DO Z_Z+1 
WSAW3:$OLDXW_WSAWV
      IF Z#6 THEN[X_1;GOTO WSAW7] 
      GETWK(OLDXW)
      $(Y+7)_OLDXW
      X_0 
WSAW5:$(OLDXW+7)_0
WSAW7:$([OLDXW_OLDXW+X])_100000K
      RETURN
      END 
! 
! WORD STRING APPEND ARRAY
! 
! CALLING SEQ:   WSAA(WST)_ ARRAY ADDRESS 
! 
WSAA: PSEUDO(WST)GLOBAL,DIRECT
      IFNOT WSAAF THEN DIAG(ERR1) 
      ARCNT_$WSAAV  !WORD COUNT 
      IF ARCNT<0 THEN[ARCNT_(ARCNT+1)/2]
      FOR I_1 TO ARCNT DO[WSAW(WST)_$(WSAAV+I)] 
      RETURN
      END 
! 
! 
! 
INWS: PSEUDO (WSPT,INDX) GLOBAL,FEXIT,DIRECT
      IFNOT WSPT THEN GOTO INWS9
      IF WSPT=WSPT2 THEN[IF INDX=INDX2+1 THEN \ 
                           [Z,Y_1;T_TW+1;\
                            IF(TW AND 7)=6 THEN T_$T;\
                            GOTO INWS3]]
      X_WSPT
      Y_INDX
INWS1:IFNOT X THEN GOTO INWS9 
      IF Y > 7 THEN [Y_Y-7; X_$(X+7); GOTO INWS1],\ 
               ELSE [Y_Y-1; Z_0]
INWS2:T_X+Z 
INWS3:IF $T=100000K THEN GOTO INWS9 
      IF Z # Y THEN [Z_Z+1; GOTO INWS2] 
      IF INWSF THEN $T_INWSV,\
               ELSE INWSV_$T
      TW_T
      INDX2_INDX
      WSPT2_WSPT
      RETURN
INWS9:IF INWSF THEN DIAG(ERR1) ,ELSE INWSV_0
      FRETURN 
      END 
! 
! 
! 
! 
! 
! 
! 
! 
!     STPRG RETURNS BLOCKS OF 8 WORDS,EITHER STRINGS OR STACKS, TO
!     THE FREE WORKSPACE AREA,ZEROING ITS ARGUMENT ON RETURN. 
!     THE LAST BLOCK IN EITHER  IS FOUND BY CHAINING THRU THE BLOCKS, 
!     UNTIL EITHER THE LAST WORD IN A BLOCK IS ZERO (STACKS &CHAR.
!     STRINGS) OR THE LAST WORD POINTS INTO THE BLOCK ITSELF (WORD STRING). 
! 
STPRG:SUBROUTINE (STRPT) GLOBAL,DIRECT
      IF STRPT=OLDCS THEN OLDCS_0 
      IF STRPT=OLDWS THEN OLDWS_0 
      WHILE STRPT DO [STRPT_$([X_STRPT] OR 7);PUTWK(X)] 
      RETURN
      END 
! 
! 
! 
! 
! 
GETWK:SUBROUTINE(GPTR)DIRECT
      IF FRLST THEN [GPTR_FRLST;FRLST_$GPTR;GOTO GET9]
      IFNOT (LAST-FIRST)>6 THEN DIAG(ERR1)
      GPTR_LAST-7 
      LAST_GPTR-1 
GET9: $(GPTR OR 7)_0
      RETURN
      END 
! 
PUTWK:SUBROUTINE(PPTR)DIRECT
      IFNOT PPTR THEN RETURN
      DO[I,K_@FRLST;L_0;M_PPTR AND 77770K]
PUT1: I_$[J_I]
      IF J-I=8 THEN GOTO PUT3 
      IF I THEN GOTO PUT4 
      IF J-M#8 THEN GOTO PUT4 
PUT3: IFNOT L THEN L_J
      GOTO PUT2 
PUT4: K_J 
      L_0 
PUT2: IF I=>M THEN GOTO PUT1
      DO[$J_M;$M_I] 
      IF M=(LAST+1)THEN[$K_0;IF L THEN[IF L#@FRLST THEN LAST_L-1];\ 
                        LAST_LAST+8]
      RETURN
      END 
! 
! 
! 
! 
! 
! 
! DIAGNOSTIC PR1NTER
! 
! 
DIAG: SUBROUTINE(ERRS)GLOBAL,DIRECT 
      CALL WRITE(ERRS)
      CALL GT0UT    !ABORT! 
      RETURN
      END 
! 
! 
CSAC: PSEUDO (CSPTR) GLOBAL,DIRECT
      IFNOT CSACF THEN DIAG(ERR1) 
      IFNOT[Y_CSPTR]THEN[GETWK(OLDXC);$([CSPTR,OLDCS_OLDXC]+7)_0;\
                         GOTO CSAC9]
      IF OLDCS=OLDWS THEN OLDCS_0 
      IF CSPTR=OLDCS THEN[Y_OLDXC AND 77770K;Z_OLDXC AND 7K;\ 
                          IF LRFLG=200K THEN GOTO CSAC5,ELSE GOTO CSAC9]
      OLDCS_CSPTR 
      WHILE $[OLDXC_Y+7] DO Y_$OLDXC
      Z_-1
CSAC1:IF($[OLDXC_Y+[Z_Z+1]]AND 177400K)=100000K THEN GOTO CSAC9 
      IF($OLDXC AND 377K)#200K THEN GOTO CSAC1
CSAC5:$OLDXC_($OLDXC AND 177400K)OR(CSACV AND 377K) 
      IF Z=6 THEN[GETWK(OLDXC);$(Y+7)_OLDXC;$(OLDXC+7)_0],\ 
             ELSE OLDXC_OLDXC+1 
      $OLDXC,LRFLG_100000K
      RETURN
CSAC9:LRFLG_200K
      $OLDXC_LRFLG OR((CSACV AND 377K)-<8)
      RETURN
      END 
! 
! 
INCS: PSEUDO (CSPT,INX) GLOBAL,FEXIT,DIRECT 
      IFNOT CSPT THEN GOTO INCS9
      IF CSPT=CSPT2 THEN[IF INX=INX2+1 THEN GOTO INC10] 
      X_CSPT
      Y_(INX+1)>-1
INCS1:IFNOT X THEN GOTO INCS9 
      IF Y>7 THEN [Y_Y-7; X_$(X+7); GOTO INCS1],\ 
             ELSE [Y_Y-1; Z_0]
INCS2:T_X+Z 
INCS7:IF($T AND 177400K)=100000K THEN GOTO INCS9
      IF($T AND 377K)=200K THEN[IF Z#Y THEN GOTO INCS9,\
                ELSE[IF INX AND 1 THEN GOTO INCS3,\ 
                                  ELSE GOTO INCS9 ]]
      IF Z # Y THEN [Z_Z+1; GOTO INCS2] 
INCS3:IF INX AND 1 THEN GOTO INCS5
      IF INCSF THEN $T_$T AND 177400K OR INCSV AND 377K,\ 
               ELSE INCSV_$T AND 377K 
      GOTO INCS6
INCS5:IF INCSF THEN $T_((INCSV AND 377K)-<8)OR $T AND 377K,\
               ELSE INCSV_($T -> 8)AND 377K 
INCS6:TC_T
      CSPT2_CSPT
      INX2_INX
      RETURN
INCS9:IF INCSF THEN DIAG(ERR1) ,ELSE INCSV_0
      FRETURN 
INC10:Y,Z_1 
      IF INX AND 1 THEN[T_TC+1;IF(T AND 7)=7 THEN T_$T],\ 
                   ELSE T_TC
      GOTO INCS7
      END 
! 
      END ISAGN 
END$
                                                                                                                                                                                                                              