         TITLE    'INDX-B00,10/10/73,DWG702985'                                 
         PAGE                                                                   
*                                                                               
*                                                                               
*  E X T E R N A L    C O M M U N I C A T I O N                                 
*                                                                               
*                                                                               
*  DEFINITIONS                                                                  
*                                                                               
         DEF      AXDRIVER          INDEXED ASSIGNMENT EXEC DRIVER              
         DEF      COORDK            K'TH COORDINATE SPEC                        
         DEF      DBUFEND           DIMENSION BUFFER END                        
         DEF      DCATEN            DYADIC CATENATE OP ROUTINE                  
         DEF      DCOMPRES          DYADIC COMPRESS OP ROUTINE                  
         DEF      DDROP             DYADIC DROP OP ROUTINE                      
         DEF      DEXPAND           DYADIC EXPAND OP ROUTINE                    
         DEF      DROTATE           DYADIC ROTATE OP ROUTINE                    
         DEF      DTAKE             DYADIC TAKE OP ROUTINE                      
         DEF      DTRANS            DYADIC TRANSPOSE OP ROUTINE                 
         DEF      EXCHLUPS          EXCHANGE MIDDLE/INNER LOOPS                 
         DEF      GSCLRVAL          GET INTEGER SCALAR VALUE                    
         DEF      INDX@            START OF PROCEDURE                           
         DEF      INDXLDLR          INDEXED LOAD LOGICAL RIGHT                  
         DEF      INERCNT           INNER LOOP COUNT                            
         DEF      INERSTEP          INNER LOOP STEP SIZE                        
         DEF      MAXDIMEN          MAXIMUM NUMBER OF DIMENSIONS                
         DEF      MBUFDIMS          MOVER BUFFER DIMENSIONS TO RS               
         DEF      MIDLCNT           MIDDLE LOOP COUNT                           
         DEF      MIDLSAVE          MIDDLE LOOP SAVE TEMP                       
         DEF      MIDLSTEP          MIDDLE LOOP STEP SIZE                       
         DEF      MREVERSE          MONADIC REVERSE OP ROUTINE                  
         DEF      MRTDIMS           MOVER RT ARG DIMENSIONS TO RS               
         DEF      MTRANS            MONADIC TRANSPOSE OP ROUTINE                
         DEF      OUTRCNT           OUTER LOOP COUNT                            
         DEF      OUTRSAVE          OUTER LOOP SAVE TEMP                        
         DEF      OUTRSTEP          OUTER LOOP STEP SIZE                        
         DEF      RSLIKRT1          ALOC RESULT LIKE RTARG                      
         DEF      RSLIKRT2          ALOC RESULT LIKE RTARG              U10-0004
         DEF      SETSPEC1          SPECIAL ADR SETUP                           
         DEF      SETSPEC2          SPECIAL ADR SETUP                           
         DEF      ST3LUPSN          SET UP LOOP PARAMS, NO ALOC                 
         DEF      SXDRIVER          SUBSCRIPTED EXPRESSION EXEC DRIVER          
         DEF      XSETUP            SET UP ADR FOR INDEXED LOAD                 
*                                                                               
*  REFERENCES                                                                   
*                                                                               
         REF      ALOCHNW           ALLOCATE HEADER AND N WORDS                 
         REF      ALOCRS            ALLOCATE RESULT DATA BLOCK                  
         REF      AXRETURN          INDEXED ASSIGNMENT EXEC RETURN              
         REF      BITMASK           BIT SELECTION MASK TABLE                    
         REF      DREF              DE-REF                                      
ERCOORD  EQU      ERRANK            COORDINATE SPECIFICATION ERROR              
         REF      ERDOMAIN          DOMAIN ERROR                                
         REF      ERINDEX           INDEX RANGE ERROR                           
         REF      ERLENGTH          LENGTH ERROR                                
         REF      ERRANK            RANK ERROR                                  
         REF      EXECUTE           EXECUTE XSEG                                
         REF      FLOT0             FLOATING PT 0.0                             
         REF      F2I               CONVERT F TO I                              
         REF      GENLOAD           GEN LOAD BY RSTYPE                          
         REF      GENLOADT          GEN LOAD TO TEMP                            
         REF      GXSEGINI          GEN XSEG INITIALIZATION                     
         REF      GXSTEXEC          GEN XSEG STORE; EXECUTE XSEG                
         REF      INBUF             INPUT BUFFER (USED AS TEMP BUFFER)          
         REF      INDXTMPS          INDX TEMPS ARE IN WINDOW IN APLUTSI U10-0006
         REF      LBLOCK            LOOP CONTROL BLOCK PNTR                     
         REF      LFADR             LEFT ARG ADDRESS                            
         REF      LFARG             LEFT ARG PNTR                               
         REF      LFLGLADR          LEFT LOGICAL DATA ADR                       
         REF      LFLGLCNT          LEFT LOGICAL BIT COUNT                      
         REF      LFRANK            LEFT ARG RANK                               
         REF      LFSIZE            LEFT ARG SIZE                               
         REF      LFTYPE            LEFT ARG TYPE                               
         REF      LOADINST          LOAD INSTRUCTION TABLE, BY TYPE             
         REF      LOOPLOC           LOOP LOCATION                               
         REF      MNOP              MONADIC NO OP ROUTINE                       
         REF      NILCK             'NIL CHECK' = SCRIPT LIST PNTR              
SCRIPT   EQU      NILCK             SUBSCRIPT LIST POINTER                      
         REF      OPER              OPERATOR WORDS                              
         REF      ORGADJ            ORIGIN, ADJUSTED (=1-ORG)                   
         REF      ORIGIN            INDEX ORIGIN VALUE (0 OR 1)                 
         REF      RESULT            RESULT DATA BLOCK POINTER                   
         REF      RETURN            RETURN ADR CELL                             
         REF      RSADR             RESULT ADDRESS                              
         REF      RSRANK            RESULT RANK                                 
         REF      RSSIZE            RESULT SIZE                                 
         REF      RSTYPE            RESULT TYPE                                 
         REF      RTADR             RIGHT ARG ADDRESS                           
         REF      RTARG             RIGHT ARG PNTR                              
         REF      RTRANK            RIGHT ARG RANK                              
         REF      RTSIZE            RIGHT ARG SIZE                              
         REF      RTTYPE            RIGHT ARG TYPE                              
         REF      SETADR            SET UP ADDRESS,     SEQUENTIAL              
         REF      SETADRS1          SET UP ADDRESSES, SEQUENTIAL                
         REF      SETUPARG          SET UP ARG PARAMS                           
         REF      STORINST          STORE INST TABLE                            
         REF      SXRETURN          SUBSCRIPTED EXP EXEC DRIVER RETURN          
         REF      SYSTERR           SYSTEM ERROR                                
         REF      TYCOMPAT          TYPE COMPATIBILITY CHECK                    
         REF      VECTORRS          ALOCATE VECTOR RESULT                       
         REF      XSEGBASE          BASE OF XSEG AREA                           
         PAGE                                                                   
*                                                                               
*                                                                               
*  A S S E M B L Y    P A R A M E T E R S                                       
*                                                                               
*                                                                               
         SYSTEM   SIG5F                                                         
PROGSECT CSECT    1                                                             
INDX@    RES      0                START OF PROCEDURE                           
*                                                                               
*  REGISTERS                                                                    
*                                                                               
IX       EQU      0                 EVEN/ODD PAIR                               
IX1      EQU      1                   *                                         
N        EQU      1                 XSEG EXECUTION REG                          
N1       EQU      4                 XSEG EXECUTION REG                          
K1       EQU      4                 XSEG EXECUTION REG                          
N2       EQU      11                XSEG EXECUTION REG                          
N3       EQU      10                XSEG EXECUTION REG                          
X        EQU      1                 SCRIPT POINTER                              
T        EQU      2                 TYPE REG                                    
NX       EQU      3                 COUNT REG                                   
XL       EQU      3                 XSEG LOC REG                                
K        EQU      2                 SUBSCRIPT VALUE                             
KB       EQU      3                 B-BLOCK POINTER                             
KN       EQU      8                 LOOP COUNT                                  
KV       EQU      9                 ARRAY LOOP OFFSET                           
KL       EQU      10                LINK REG                                    
A        EQU      4                 ARG ADR/INDEX                               
LZ       EQU      4                 INDEX LINK REG                              
LX       EQU      5                 INDEX LINK REG                              
OP       EQU      6                 OP CODE REG                                 
AF       EQU      6                 ACCUM FOR FLOT VALUES                       
AF1      EQU      7                    *                                        
LX7      EQU      7                 INDEX LINK REG                              
AI       EQU      7                 ACCUM FOR LOGL/CHAR/INTG VALUES             
BUF      EQU      7                 BUFFER FOR MOVING DATA/CODE GROUPS          
R        EQU      8                 GENERAL WORK REG                            
BI       EQU      9                 2ND ACCUM FOR L/C/I VALUES                  
S        EQU      11                SIZE                                        
L3       EQU      12                LINK REG                                    
L2       EQU      13                LINK REG                                    
L1       EQU      14                LINK REG                                    
R15      EQU      15                                                            
*                                                                               
*  ARG TYPE CODES                                                               
*                                                                               
LOGL     EQU      1                 LOGICAL (BIT)                               
CHAR     EQU      2                 CHARACTER (BYTE)                            
INTG     EQU      3                 INTEGER (WORD)                              
FLOT     EQU      4                 FLOATING (DOUBLEWORD)                       
ISEQ     EQU      5                 INDEX SEQUENCE VECTOR                       
LIST     EQU      6                 LIST                                        
*                                                                               
*  CODESTRING DESIGNATIONS                                                      
*                                                                               
DOPCMPRS EQU      84                DYADIC COMPRESS                             
DOPCATEN EQU      87                DYADIC CATENATE/LAMINATE                    
DOPTAKE  EQU      116               DYADIC TAKE                                 
*                                                                               
*  B-BLOCK STRUCTURE PARAMETERS                                                 
*                                                                               
BN       EQU      6                 B BLOCK ITEM SIZE                           
BSTEPVAL EQU      0                 OFFSET TO STEP VALUE                        
BINITOFS EQU      0                 OFFSET TO INITIAL OFFSET VALUE              
BINITCNT EQU      1                 OFFSET TO INITIAL COUNT                     
BNULLCNT EQU      1                 OFFSET TO NULL GROUP COUNT                  
BSCRIPT  EQU      2                 OFFSET TO SCRIPT SAVE LOC                   
BOFFSET  EQU      2                 OFFSET TO OFFSET SAVE LOC                   
BCOUNT   EQU      3                 OFFSET TO COUNT SAVE LOC                    
BADDEND  EQU      4                 OFFSET TO ADDEND VALUE                      
BNULTEST EQU      4                 OFFSET TO NULL TEST VALUE                   
BLOOPTYP EQU      5                 OFFSET TO LOOP TYPE CODE                    
*                                                                               
SEQLOOP  EQU      0                 SEQUENCE LOOP                               
ARAYLOOP EQU      -1                ARRAY LOOP                                  
MIXLOOP  EQU      -2                MIXED SEQUENCE LONP                         
LOPBIAS  EQU      -2                LOOP TYPE CODE BIAS                         
*                                                                               
*  DIMENSION BUFFER PARAMETERS                                                  
*                                                                               
MAXDIMEN EQU      63                MAXIMUM NUMBER OF DIMENSIONS                
DIMENBUF EQU      XSEGBASE          DIMENSION BUFFER START                      
DBUFEND  EQU      DIMENBUF+MAXDIMEN DIMENSION BUFFER END                        
*                                                                               
*  MISCELLANEOUS PARAMETERS                                                     
*                                                                               
INFINITY EQU      1**19-1           PLUS INFINITY (FOR 'LI')                    
LAMBIT   EQU      X'40'             LAMINATE BIT                                
         PAGE                                                                   
*                                                                               
*                                                                               
*  P R O C S                                                                    
*                                                                               
*                                                                               
TLOC     SET      0                                                     U10-0008
*                                                                               
TEMP     CNAME    1                                                             
DTEMP    CNAME    2                                                             
         PROC                                                                   
         DO1      NAME=2                                                        
TLOC     SET      TLOC+(TLOC&1)                                         U10-0011
         DISP     TLOC                                                  U10-0012
LF       EQU      INDXTMPS+TLOC                                         U10-0013
TLOC     SET      TLOC+NAME                                             U10-0014
         PEND                                                                   
*                                                                               
*                                                                               
EVEN     CNAME    0                                                             
ODD      CNAME    1                                                             
         PROC                                                                   
LF       EQU      %                                                             
         ERROR,1,(CF(2)+NAME)&1   'REGISTER HAS WRONG PARITY'                   
         PEND                                                                   
*                                                                               
*                                                                               
EQUAL    CNAME                                                                  
         PROC                                                                   
LF       EQU      %                                                             
         ERROR,1,1-(CF(2)=CF(3))  'REGISTERS MUST BE EQUAL'                     
         PEND                                                                   
*                                                                               
*                                                                               
EXCHANGE CNAME                                                                  
         OPEN     I,K,GROUP                                                     
GROUP    EQU      LFARG,LFTYPE,LFSIZE,LFRANK,LFADR                              
         PROC                                                                   
LF       EQU      %                                                             
I        DO       NUM(AF)                                                       
K        SET      SCOR(AF(I),ARGS,TYPES,SIZES,RANKS,ADRS)                       
         ERROR,1,K=0                'UNKNOWN GROUP INDICATOR'                   
         LW,R     GROUP(K)                                                      
         XW,R     GROUP(K)+1                                                    
         STW,R    GROUP(K)                                                      
         FIN                                                                    
         PEND                                                                   
         CLOSE    I,K,GROUP                                                     
*                                                                               
*                                                                               
ISEQFIX  CNAME                                                                  
         PROC                                                                   
LF       CI,CF(2)  ISEQ                                                         
         BNE       %+2                                                          
         LI,CF(2)  INTG                                                         
         PEND                                                                   
         PAGE                                                                   
*                                                                               
*                                                                               
*  XSEG GEN PROCS                                                               
*                                                                               
*                                                                               
         OPEN     GEN                                                           
GEN      CNAME                                                                  
         OPEN     M,N,MN,I                                                      
         PROC                                                                   
LF       EQU      %                                                             
         ERROR,1,1-(NUM(CF)=3)  'WRONG NUMBER OF CF ARGS'                       
M        SET      CF(2)                                                         
N        SET      CF(3)                                                         
MN       SET      M+N                                                           
         ERROR,1,1-(NUM(AF)=(M>0)+(N>0)) 'WRONG NUMBER OF AF ARGS'              
         DO       M>0                                                           
I          DO       N                                                           
             LW,AF(1)+M+I-1  AF(2)+I-1                                          
           FIN                                                                  
I          DO       MN*(MN<3)                                                   
             STW,AF(1)+I-1   I-1,XL                                             
           ELSE                                                                 
             LCI         MN                                                     
             STM,AF(1)   0,XL                                                   
           FIN                                                                  
         ELSE                                                                   
I          DO       MN*(MN<3)                                                   
             LW,BUF      AF(1)+I-1                                              
             STW,BUF     I-1,XL                                                 
           ELSE                                                                 
             LCI         N                                                      
             LM,BUF      AF(1)                                                  
             STM,BUF     0,XL                                                   
           FIN                                                                  
         FIN                                                                    
         AI,XL    MN                                                            
         PEND                                                                   
         CLOSE    M,N,MN,I                                                      
         PAGE                                                                   
*                                                                               
*                                                                               
*  TABLE BUILDING PROCS                                                         
*                                                                               
*                                                                               
TABLE    CNAME                                                                  
         OPEN     T,N                                                           
         PROC                                                                   
T        SET      %-AF(1)                                                       
LF       EQU      T                                                             
         DISP     T                                                             
         PEND                                                                   
*                                                                               
*                                                                               
ITEM     CNAME                                                                  
         PROC                                                                   
N        SET      T+AF(1)-%                                                     
         ERROR,1,N<0           'ITEM OUT OF SEQUENCE'                           
         RES      N*(N>0)                                                       
         DISP     AF(1)                                                         
         PEND                                                                   
         CLOSE    T,N                                                           
          PAGE                                                                  
*                                                                               
*                                                                               
*  O P E R A T O R    E X E C U T I O N    D R I V E R S                        
*                                                                               
*                                                                               
         USECT    PROGSECT                                                      
*                                                                               
*                                                                               
*  SUBSCRIPTED EXPRESSION EXECUTION DRIVER                                      
*                                                                               
*              ENTERED WITH SUBSCRIPT LIST POINTER IN 'SCRIPT' AND              
*              POINTER TO EXPRESSION-TO-BE-SUBSCRIPTED IN 'LFARG'.              
*              IF NO ERRORS OCCUR, IT RETURNS TO 'SXRETURN' WITH                
*              RESULT POINTER IN 'RESULT', AND 'SCRIPT' DE-REFFED.              
*              LEFT ARG POINTER WILL HAVE BEEN MOVED TO 'RTARG',                
*              WHICH, ALONG WITH 'LBLOCK', STILLS NEEDS TO                      
*              BE DE-REFFED.                                                    
*                                                                               
*                                                                               
SXDRIVER EQU      %                 SUBSCRIPTED EXPRESSION EXEC DRIVER          
         LI,A     SXRETURN          SET UP RETURN ADDRESS                       
         STW,A    RETURN                                                        
         EXCHANGE ARGS              PUT ARG PNTR IN RTARG.                      
         BAL,L2   INDEXA            BUILD LOOP CONTROL BLOCK FROM               
*                                     SCRIPT LIST; SET SIZE/RANK.               
         LB,T    *RTARG                                                         
         CI,T     LIST              DISALLOW LIST INDEXING                      
         BGE      ERDOMAIN                                                      
         ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         STW,T    RSTYPE            SET TYPE                                    
*                                                                               
ALSELECT EQU      %                                                             
         LW,S     RSSIZE                                                        
         BAL,L1   ALOCRS            ALLOCATE RESULT DATA BLOCK                  
         BAL,LX   MBUFDIMS          MOVE DIMENS FROM BUFFER TO RS               
MTSELECT EQU      %                                                             
         LI,X     -1                                                            
         BAL,LX   SETADR            SET RSADR FOR SEQUENTIAL STORE              
         BAL,LX   GXSEGINI          GEN XSEG INIT; EXIT IF RESULT NULL          
         GEN,0,1  BAL1STSC          GEN:     BAL,L1  1STSCRPT                   
         LI,A     1                                                             
         BAL,LX   XSETUP            SET RTADR FOR INDEXED LOAD                  
         LB,T    *RTARG                                                         
         AW,R     LOADINST,T        GEN INDEXED LOAD                            
         GEN,1,0  R                                                             
         LI,A     NXTSCRPT          SET TO LOOP BACK TO 'NXTSCRPT'              
         STW,A    LOOPLOC                                                       
         B        GXSTEXEC          GEN STORE/LOOP CONTROL; EXECUTE             
*                                                                               
*                                                                               
*              XSEG CODE:                                               U10-0016
*                                                                       U10-0017
*                                                                       U10-0018
*        LCW,N    RSSIZE            INIT STORE INDEX                    U10-0019
BAL1STSC BAL,L1   1STSCRPT          1ST SCRIPT CALL INST                        
*        LOAD     RTARG(K)          LOAD SELECTED ARG ELMT              U10-0021
*        STORE    RESULT(N)         STORE IN RESULT                     U10-0022
*        BIR,N    NXTSCRPT          BUMP N, GET NEXT K                  U10-0023
*        B       *RETURN            EXIT WHEN RESULT FILLED             U10-0024
         PAGE                                                                   
*                                                                               
*                                                                               
*  INDEXED ASSIGNMENT EXECUTION DRIVER                                          
*                                                                               
*              ENTERED WITH SUBSCRIPT LIST POINTER IN 'SCRIPT',                 
*              POINTER TO INDEXED VARIABLE (ON LEFT SIDE OF ASSIGNMENT          
*              ARROW) IN 'LFARG', AND POINTER TO THE VALUE-TO-ASSIGN            
*              IN 'RTARG'.  IF NO ERROR OCCUR, IT RETURNS TO 'AXRETURN'         
*              WITH RESULT POINTER (VALUE OF THE 'LFARG' VARIABLE,              
*              AFTER THE INDEXED ASSIGNMENT) IN 'RESULT', AND 'SCRIPT'          
*              DE-REFFED.  'LBLOCK' STILL NEEDS TO BE DE-REFFED.                
*                                                                               
AXDRIVER EQU      %                 INDEXED ASSIGNMENT EXEC DRIVER              
         LI,A     AXRETURN          SET RETURN ADR                              
         STW,A    RETURN                                                        
         EXCHANGE ARGS              SWAP ARGS                                   
         BAL,L2   INDEXA            BUILD LOOP CONTROL BLOCK FROM               
*                                     SCRIPT LIST; SET SHAPE PARAMS.            
         LI,A     0                 SET UP PARAMS FOR                           
         BAL,LX   SETUPARG            VALUE TO BE ASSIGNED.                     
         LI,A     1                 SET UP PARAMS FOR                           
         BAL,LX   SETUPARG            IND.VAR.                                  
         BAL,LX   TYCOMPAT          MAKE SURE THE TYPES ARE COMPATIBLE,         
         B        ERDOMAIN            PUT HIGHEST TYPE IN RSTYPE.               
         LW,S     RSSIZE            SET SCRIPT SIZE (NUMBER                     
         STW,S    SCRPTCNT            OF SCRIPT VALUES).                        
         LI,S     1                                                             
         CW,S     LFSIZE            IF ASSIGN VALUE IS 1-ELMT,                  
         BE       14Z2                SKIP RANK/DIMEN CHECKS.                   
         LI,AI    1                                                     10-00071
         LW,A     LFARG             SET UP TO COMPARE DIMENS OF ASSIGN  10-00072
         LW,R     LFRANK              VALUE AND SUBSCRIPT STRUCTURE.    10-00073
         AI,R     1                 EXCEPT FOR 1'S (WHICH ARE SKIPPED   10-00074
         LCW,K    RSRANK              OVER), THESE DIMENS MUST MATCH.   10-00075
         AI,K     -1                                                    10-00076
14Z10    BDR,R    14Z13             GET A DIMEN FROM ASSIGN VALUE       10-00077
14Z11    BIR,K    14Z12             NO MORE: REMAINING SCRIPT                   
         B        14Z2                DIMENS MUST ALL BE 1'S.           10-00079
14Z12    CW,AI    DBUFEND,K                                             10-00080
         BE       14Z11                                                 10-00081
         B        ERRANK                                                10-00082
14Z13    LW,S     2,A               (NEXT ASSIGN-VALUE DIMEN)           10-00083
         AI,A     1                                                     10-00084
         CI,S     1                 IF IT'S 1, SKIP IT AND GET ANOTHER  10-00085
         BE       14Z10                                                 10-00086
14Z14    BIR,K     14Z15             GET NEXT SCRIPT DIMEN                      
         B        ERRANK            (THERE HAD BETTER BE ONE)           10-00088
14Z15    CW,AI    DBUFEND,K         IF IT'S 1, SKIP IT & GET NEXT       10-00089
         BE       14Z14                                                 10-00090
         CW,S     DBUFEND,K         BOTH DIMENS NON 1: THEY             10-00091
         BE       14Z10               ARE REQUIRED TO AGREE.            10-00092
         B        ERLENGTH                                              10-00093
14Z2     LW,S     SCRPTCNT          IF INDEX NULL,SET RESULT=           10-00061
         BEZ      MNOP                INDEXED VARIABLE.                         
         LW,OP    LFTYPE            TEST FOR SPECIAL CASE:              U10-0026
         CW,OP    RTTYPE              ALLOW ONLY IF LFARG IS CONVERTIBLEU10-0027
         BG       14Z21               TO RTARG'S TYPE,                  U10-0028
         LI,OP    ISEQ                RT ARG IS NOT AN ISEQ,                    
         CW,OP    RTTYPE                                                        
         BE       14Z21                                                         
         LW,A     RTARG                                                 U10-0029
         LW,R     1,A                 AND RTARG IS RE-USABLE AS RESULT  U10-0030
         AI,R     -2                  (I.E., ITS REF COUNT IS 2).       U10-0031
         BNEZ     14Z21             NO GOOD                             U10-0032
*                                   GOOD: CONDITIONS FOR THE SPECIAL    U10-0033
*                                     CASE HAVE BEEN MET. WE'LL NOW     U10-0034
*                                     USE RTARG FOR THE RESULT.         U10-0035
         LI,OP    -100              SIGNAL TO GEN SPECIAL CODE          U10-0036
         MTW,1    1,A               CREATE NEW COPY OF RTARG PTR        U10-0037
         STW,A    RESULT            USE IT FOR RESULT PTR               U10-0038
         B        14Z22             JOIN GENERAL CASE                   U10-0039
14Z21    EQU      %                 GENERAL CASE: ALOC NEW RS BLOCK     U10-0040
         BAL,L1   RSLIKRT2          ALOC RS WITH SHAPE = IND.VAR.SHAPE          
         BAL,LX   MRTDIMS           MOVE IND.VAR. DIMENS TO RESULT              
14Z22    LW,S     RTSIZE            IF IND.VAR. IS NULL,                U10-0042
         BEZ     *RETURN              THEN SO IS RESULT.                        
         LI,X     -3                                                            
         BAL,LX   SETADR            ST LFADR FOR SEQ LOAD (N)                   
         LI,A     1                                                             
         BAL,LX   XSETUP            SET RTADR FOR INDX LOAD (K)                 
         LI,A     2                                                             
         BAL,LX   XSETUP            SET RSADR FOR INDX STORE (K)                
         LI,XL    XSEGBASE          PREPARE TO GEN XSEG CODE                    
         LI,S     1                                                             
         CW,S     LFSIZE            IF ASSIGN VALUE IS 1-ELMT,                  
         BNE      14Z3                                                          
         LI,A     0                 GEN LOAD/CONVERT ASSIGN                     
         BAL,L2   GENLOADT            VALUE TO TEMP.                            
14Z3     BIR,OP   14Z4              JUMP IF SPECIAL CASE                U10-0044
         STW,XL   LOOPLOC           GENERAL CASE                        U10-0045
         GEN,0,9  CODE7             GEN K-LOOP CONTROL                          
         AWM,XL   -7,XL                                                         
         B        14Z5              JOIN SPECIAL CASE                   U10-0047
14Z4     GEN,0,1  BAL1STSC          SPECIAL CASE: SIMPLER K-LOOP CONTROLU10-0048
14Z5     EQU      %                 COMMON CODE                         U10-0049
         LI,A     0                 GEN LOAD/CONVERT OF ASSIGN-VALUE            
         BAL,L1   GENLOAD             ELMT FOR SELECTED POSITION.               
         LW,T     RSTYPE                                                        
         LW,R     STORINST,T        SET UP STORE INST                           
         AW,R     RSADR                                                         
         BIR,OP   14Z6              JUMP IF SPECIAL CASE                U10-0051
         STW,R    TEMP                                                          
         GEN,1,4  R,CODE8           GEN N-LOOP  CONTROL                         
         LW,X     LOOPLOC                                                       
         AWM,X    -1,XL             FILL IN BRANCH ADR                          
         AWM,XL   6,X                                                           
         LI,A     1                 GEN LOAD/CONVERT OF IND.VAR. TO             
         BAL,L1   GENLOAD             FILL IN NON-SELECTED ELMTS.               
         LW,R     TEMP                                                          
         GEN,1,1  R,CODE11          GEN STORE/N-LOOP CONTROL 3                  
         LW,X     LOOPLOC                                                       
         AWM,X    -1,XL             FILL IN BRACH ADR                           
*                                                                               
         LI,R     -1                PREPARE FOR XSEG EXECUTION:                 
         STW,R    KTEMP               'OLD K' = -1,                             
         B        14Z7              JOIN SPECIAL CASE                   U10-0053
14Z6     GEN,1,3  R,CODE13          SPECIAL CASE: SIMPLER STORE CONTROL U10-0054
14Z7     EQU      %                 COMMON CODE                         U10-0055
         LCW,N    LFSIZE              N  = ASSIGN-VALUE INDEX                   
         LW,N2    SCRPTCNT            N2 = NUMBER OF SCRIPT VALUES              
         BIR,OP   XSEGBASE          IF SPECIAL CASE, DONT ALLOW BREAKS  U10-0057
         B        EXECUTE                                                       
*                                                                               
KTEMP    EQU      TEMP                                                          
SCRPTCNT EQU      INERCNT                                                       
*                                                                               
*                                                                               
*              XSEG CODE:                                                       
*                                                                               
*        LOAD/CNV LFARG             (ONLY IF LFARG IS                   U10-0059
*        STORE    LFTEMP              1-ELEMENT).                               
CODE7    BAL,L1   1STSCRPT          GET INDEX (K) OF 1ST SELECTED ELMT          
         CW,K     KTEMP             IF NEW INDEX <= PREVIOUS                    
         BLE      0  (LOOP1)          ONE, GO BACK & STORE IN IT.               
         XW,K     KTEMP             SWAP W/INDEX OF PREVIOUS SEL.ELMT           
         AI,K     1                 IF THERE'S A GAP,                           
         CW,K     KTEMP                                                         
         BNE      0       (LOOP2)     GO FILL IN WITH IND.VAR. VALUES.          
         CW,K     RSSIZE            IF THIS IS THE FINAL FILL-OUT               
         BGE     *RETURN              PASS, STOP WHEN FULL.                     
*LOOP1   LOAD/CNV LFARG(N)          FETCH NEXT ELMT OF ASSIGN-VALUE             
*        STORE    RESULT(K)         STORE ASSIGN-VALUE ELMT                     
CODE8    AI,N     1                 BUMP ASSIGN-VALUE INDEX                     
         BDR,N2   NXTSCRPT          GET NEXT INDEX                              
         LW,K     RSSIZE            NO MORE INDECES, SET TO FILL                
         B        3  (XW,K)           OUT RESULT W/ IND.VAR. ELMTS.             
*LOOP2   LOAD/CNV RTARG(K)          FETCH IND.VAR. ELMT TO FILL INTO            
*        STORE    RESULT(K)           NON-SELECTED RESULT POSITION.             
CODE11   B        4  (AI,K)         KEEP FILLING 'TIL WE HIT SELECTED           
*                                     POSITION, OR FILL UP RESULT.              
*                                                                       U10-0061
*                                                                       U10-0062
*              XSEG CODE FOR SPECIAL CASE (RTARG=RESULT):               U10-0063
*                                                                       U10-0064
*        LOAD/CNV LFARG             (ONLY IF LFARG IS                   U10-0065
*        STORE    LFTEMP              1-ELEMENT).                       U10-0066
*        BAL,L1   1STSCRPT          GET 1ST K-VALUE                     U10-0067
*        LOAD/CNV LFARG(N)          GET NEXT ELEMENT OF ASSIGN VALUE    U10-0068
*        STORE    RESULT(K)         STORE INTO SELECTED RESULT POSITION U10-0069
CODE13   AI,N     1                 BUMP LOAD INDEX                     U10-0070
         BDR,N2   NXTSCRPT          GET NEXT K-VALUE                    U10-0071
         B       *RETURN            EXIT WHEN ALL K-VALUES USED         U10-0072
         PAGE                                                                   
*                                                                               
*                                                                               
*  M O N A D I C    I N D E X I N G    O P    R O U T I N E S                   
*                                                                               
*                                                                               
MTRANS   EQU      %                 MONADIC TRANSPOSE                           
         LI,A     1                                                             
         BAL,LX   SETUPARG          SET UP RT ARG PARAMS                        
         LW,S     RTRANK            GET ARG RANK                                
         CI,S     1                 IF ARG IS A SCALAR OR VECTOR,               
         BLE      MNOP                RESULT = ARG.                             
         BAL,L2   INDEXB            RANK>=2: ALOC LOOP CONTROL BLOCK            
         BAL,L1   RSLIKERT          ALOC RESULT DB LIKE ARG DB                  
         LW,KB    OUTRBLOK          PREPARE TO SET UP LOOP CONTROLS             
         LI,OP    SEQLOOP           LOOP TYPE = SEQUENCIAL                      
         LI,S     1                 FIRST STEP VAL = 1                          
         LW,A     RESULT            INCREASING DIMEN INDEX                      
         LW,X     RTRANK            DECREASING DIMEN INDEX AND COUNTER          
         MTW,1    RTARG             POINT TO ARG DIMENS                         
*                                FOR LOOP(K) ...                                
22Z1     STW,OP   BLOOPTYP,KB       TYPE = SEQUENCIAL                           
         STW,S    BSTEPVAL,KB       STEP = D(N)*D(N-1)*...*D(N+2-K)             
         LW,R    *RTARG,X                                                       
         STW,R    BINITCNT,KB       COUNT = D(N+1-K)                            
         STW,R    2,A               SET K'TH RESULT DIMEN = D(N+1-K)            
         MW,S    *RTARG,X           UPDATE STEP VALUE: MULT BY D(N+1-K)         
         AI,A     1                 BUMP INCREASING DIMEN INDEX                 
         AI,KB    +BN               BUMP TO NEXT HIGHER LOOP BLOCK              
         BDR,X    22Z1              BUMP DECREASING DIMEN INDEX, COUNT          
         MTW,-1   RTARG             CORRECT ARG POINTER                         
         B        MTSELECT          USE LOOP CONTROL BLOCK TO PICK              
*                                     RESULT ELEMENTS IN CORRECT ORDER.         
         PAGE                                                                   
*                                                                               
*                                                                               
MREVERSE EQU      %                 MONADIC REVERSE                             
         LB,T    *RTARG             GET ARGUMENT TYPE                           
         CI,T     LIST                                                          
         BGE      ERDOMAIN           DISALLOW LIST OR ABOVE                     
         CI,T     ISEQ              IS IT AN ISEQ                               
         BNE      23Z1              NO, FORGET IT.                              
         LB,S     OPER+1            CHECK FOR COORDINATE SPEC.                  
         BDR,S    ERCOORD            ERROR IF GREATER THAN 1                    
         LI,S     3                 YES, CREATE AN ISEQ RESULT                  
         BAL,LX7  ALOCHNW           ALOC DATA BLOCK FOR RESULT                  
         STW,A    RESULT            SAVE POINTER                                
         LI,R     ISEQ**8+1         TYPE=ISEQ, RANK=1                           
         STH,R   *RESULT                                                        
         LW,X     RTARG             GET ARG POINTER                             
         LW,S     2,X               COMPUTE RESULT BASE VALUE =                 
         AI,S     1                   A+B*(N+1)   WHERE A/B ARE                 
         ODD,S                                                                  
         MW,S     4,X                 THE ARG BASE/STEP VALUES.                 
         AW,S     3,X                                                           
         LCW,S+1  4,X               RESULT STEP = -B                            
         LW,S-1   2,X               RESULT SIZE =  N                            
         LCI      3                 STORE RESULT SIZE/BASE/STEP                 
         STM,S-1  2,A                 IN RESULT DATA BLOCK.                     
         B       *RETURN            EXIT                                        
23Z1     EQU      %                 ARG NOT ISEQ: PROCEED NORMALLY              
         BAL,L2   SET3LUPS          SET UP LOOP PARAMETERS                      
         LCW,R    MIDLSTEP            MIDDLE LOOP STEP =                        
         STW,R    MIDLSTEP            -D(K+1)*...*D(N).                         
         AW,R     OUTRSTEP          FVALUE =                                    
         STW,R    FVALUE              (D(K)-1)*(D(K+1)*...*D(N).                
INDXOP1  LI,A     1                 SET UP RT ADR FOR INDEXED LOAD              
         BAL,LX   XSETUP                                                        
         LI,X     -1                SET UP RS ADR FOR SEQUENTIAL STORE          
         BAL,LX   SETADR                                                        
         LI,XL    XSEGBASE          PREPARE TO GEN XSEG                         
         GEN,0,7  CODE1             GEN OUTER/MIDDLE LOOP INIT CODE             
         STW,XL   LOOPLOC           INNER LOOP LOC HERE                         
         LB,T    *RTARG                                                         
         LW,R     LOADINST,T        GEN LOAD OF RIGHT ARG,                      
         AW,R     RTADR                                                         
         LW,R+1   STORINST,T            STORE TO RESULT,                        
         AW,R+1   RSADR                                                         
         GEN,2,1  R,AIN1INST            INCREMENT OF STORE INDEX.               
         GEN,0,9  CODE3             GEN INNER LOOP CONTROL                      
         LW,R     LOOPLOC                                                       
         AWM,R    -8,XL                                                         
         B        EXECUTE           EXECUTE XSEG                                
*                                                                               
*              XSEG CODE:                                                       
*                                                                               
CODE1    LCW,N    RSSIZE            0   INIT STORE INDEX                        
         LW,K     FVALUE            1   INIT INDEX                              
         LW,N1    OUTRCNT           2   INIT OUTER LOOP                         
         STW,K    OUTRSAVE          3   SAVE INDEX FOR OUTER  LOOP              
         LW,N2    MIDLCNT           4   INIT MIDDLE LOOP                        
         STW,K    MIDLSAVE          5   SAVE INDEX FOR MIDDLE LOOP              
         LW,N3    INERCNT           6   INIT INNER LOOP                         
*        LOAD     RTARG(K)              LOAD ARG                                
*        STORE    RESULT(N)             STORE RESULT                            
AIN1INST AI,N     1                     BUMP STORE INDEX                        
CODE3    AW,K     INERSTEP              BUMP BY INNER LOOP STEP                 
         BDR,N3   0  (INNER LOOP LOC)   COUNT INNER LOOP                        
CODE5    LW,K     MIDLSAVE              RESTORE INDEX FOR MIDDLE LOOP           
         AW,K     MIDLSTEP              BUMP BY MIDDLE LOOP STEP                
         BDR,N2   XSEGBASE+5            COUNT MIDDLE LOOP                       
         LW,K     OUTRSAVE              RESTORE INDEX FOR OUTER LOOP            
         AW,K     OUTRSTEP              BUMP BY OUTER LOOP STEP                 
         BDR,N1   XSEGBASE+3            COUNT OUTER LOOP                        
         B       *RETURN                EXIT                                    
         PAGE                                                                   
*                                                                               
*                                                                               
*  D Y A D I C    I N D E X I N G    O P    R O U T I N E S                     
*                                                                               
*                                                                               
DROTATE  EQU      %                 DYADIC ROTATE                               
         BAL,LX   LISTCHK           CHECK ARGUMENTS FOR LIST                    
         BAL,L2   SET3LUPS          SET UP LOOP PARAMS                          
         BAL,LX   EXCHLUPS          EXCHANGE INNER/MIDDLE LOOPS                 
         LI,R     0                 INIT FIXED PART VALUE                       
         STW,R    FVALUE                                                        
         LI,A     1                                                             
         BAL,LX   XSETUP            SET RIGHT ARG                               
         LI,A     2                   AND RESULT                                
         BAL,LX   XSETUP              FOR INDICIAL ACCESS.                      
         LI,XL    XSEGBASE          PREPARE TO GEN CODE                         
         GEN,0,7  CODE1             GEN OUTER/MIDDLE LOOP INIT/SAVE             
         MTW,-2   XSEGBASE          CHANGE 'RSSIZE' TO 'LFSIZE'                 
         LI,X     1                 THERE ARE TWO CASES OF ROTATE,              
         LB,R    *LFARG,X             DEPENDING ON LEFT ARG RANK:               
         BGZ      13Z3              >0: GENERAL CASE                            
         LW,X     LFARG             =0 (SCALAR): MUCH LIKE 'REVERSE'            
         LB,T    *LFARG                                                         
         BAL,LZ   GSCLRVAL,T        GET VALUE OF LEFT ARG (AS INTG)             
13Z0     BGEZ     13Z1                                                          
         LI,AI-1  -1                EXTEND SIGN                                 
         B        13Z2                                                          
13Z1     LI,AI-1  0                                                             
13Z2     DW,AI-1  INERCNT           COMPUTE MOD(LFARG,D(K))                     
         AI,AI-1  0                                                             
         BGEZ     13Z21             MAKE SURE SHIFT>=0                          
         AW,AI-1  INERCNT                                                       
13Z21    STW,AI-1 TESTVAL             = SPECIAL MIDL LOOP VALUE                 
         LW,AI    TESTVAL                                                       
         MW,AI    INERSTEP          INIT DELTA =                                
         STW,AI   IDELTA              SHIFT*D(K+1)*...*D(N).                    
         GEN,0,2  CODE4             GEN COPY IDELTA TO DELTA                    
         B        13Z9              JOIN GENERAL CASE                           
13Z3     LI,A     0                 GENERAL CASE                                
         STW,XL   TEMP                                                  10-00003
         BAL,LX   SETUPARG          SET UP LFARG PARAMS.                        
         LW,XL    TEMP                                                  10-00005
         AI,X     1                 X=BLOCK POINTER+RANK+1                      
         AI,AI    -1                CHECK IF LEFT ARGUMENT HAS 1 ELEM.          
         BNEZ     13Z31               NO-GO TO NORMAL PROCESSING                
         LI,S     1                   YES-FETCH THE SOLITARY ARRAY              
         BAL,LZ   GARAYVAL,T           VALUE AND TREAT AS SCALAR.               
         BAL,R15  SYSTERR           THIS POINT SHOULDN'T BE REACHED.            
         B        13Z0                                                          
13Z31    SW,X     LFARG             X=LFRANK+1                                  
         CW,X     RTRANK             NORMAL CASE,CHECK FOR RANK                 
         BNE      ERRANK              CONFORMABILITY.                           
         LW,S     LFARG             SAVE LFARG PTR                              
         MTW,1    RTARG             POINT TO 1ST DIMEN -1                       
13Z4     CW,X     COORDK            IF WE'VE GOTTEN TO K'TH COORD,              
         BNE      13Z6                                                          
         MTW,1    LFARG               LINE UP LF/RT DIMEN PTRS.                 
13Z5     BDR,X    13Z4                                                          
         B        13Z7                                                          
13Z6     LW,R    *LFARG,X           MAKE SURE (ALL) LF DIMENS =                 
         CW,R    *RTARG,X             RT DIMENS (K'TH ONE DELETED).             
         BE       13Z5                                                          
         STW,S    LFARG             NO GOOD: RESTORE PNTRS                      
         MTW,-1   RTARG                                                         
         B        ERLENGTH            AND SIGNAL ERROR.                         
13Z7     STW,S    LFARG             OK: RESTORE PNTRS                           
         MTW,-1   RTARG                                                         
         LI,X     -3                SET LEFT ARG FOR                            
         BAL,LX   SETADR              SEQUENTIAL LOAD.                          
         LI,T     INTG                                                          
         STW,T    RSTYPE                                                        
         LI,A     0                                                             
         BAL,L1   GENLOAD           GEN LOAD LEFT(N) IN INTG TYPE               
         LW,T     LFTYPE                                                        
         GEN,0,3  CODE2             GEN LCC TEST CODE                           
13Z9     STW,XL   LOOPLOC           SAVE INNER LOOP LOC                         
         GEN,0,1  AWKDELTA          GEN ADD OF DELTA                            
         LW,T     RTTYPE                                                        
         LW,A     LOADINST,T        GEN LOAD RIGHT(K),                          
         AW,A     RTADR                                                         
         LW,A+1   SWKDELTA              SUBTRACT OF DELTA,                      
         ISEQFIX,T                                                              
         LW,A+2   STORINST,T            STORE RESULT(K),                        
         AW,A+2   RSADR                                                         
         GEN,3,2  A,CODE6               AND LOOP CONTROL CODE.                  
         GEN,0,7  CODE5                                                         
         B        EXECUTE                                                       
*                                                                               
*              XSEG CODE:                                                       
*                                                                               
*        SET OUTER LOOP                                                         
*        SET MIDDLE LOOP                                                        
*        LOAD/CNV LFARG(N)          GET A SHIFT COUNT                           
CODE2    BGEZ     ROTATE1           EXTEND SIGN(AI) INTO AI-1                   
         LI,AI-1  -1                                                            
         B        ROTATE2                                                       
CODE4    LW,R     IDELTA            RE-INIT DELTA (ONLY FOR                     
         STW,R    DELTA               ROTATE W/SCALAR LFARG).                   
ROTATE1  LI,AI-1  0              *(THIS CODE NOT IN XSEG)                       
ROTATE2  AI,N     1              *  BUMP LFARG INDEX                            
         DW,AI-1  INERCNT        *  COMPUTE J=MOD(SHIFT COUNT, D(K))            
         AI,AI-1  0              *                                              
         BGEZ     13Z91          *  MAKE SURE J>=0                              
         AW,AI-1  INERCNT        *                                              
13Z91    STW,AI-1 TESTVAL        *  J                                           
         LW,AI    TESTVAL        *  DELTA (DISTANCE BETWEEN UNSHIFTED           
         MW,AI    INERSTEP       *    AND SHIFTED INDEX VALUES)                 
         STW,AI   DELTA          *    = J*D(K+1)*D(K+2)*...*D(N).               
         LW,N3    INERCNT        *  RUN INNER LOOP D(K) TIMES                   
ROTATE3  CW,N3    TESTVAL        *  UPON STARTING THE D(K)-J+1 'TH              
         BNE     *LOOPLOC        *    ITERATION OF INNER LOOP,                  
         LCW,R    OUTRSTEP       *    DECR DELTA BY D(K)*D(K+1)*...*D(N)        
         AWM,R    DELTA          *    TO KEEP K'TH COORD INDEX                  
         B       *LOOPLOC        *    IN BOUNDS.                                
*LOOPLOC EQU      %                                                             
AWKDELTA AW,K     DELTA             SHIFT INDEX                                 
*        LOAD     RTARG(K)          FETCH, SHIFTEDLY                            
SWKDELTA SW,K     DELTA             UNSHIFT INDEX                               
*        STORE    RESULT(K)         STORE, UNSHIFTEDLY                          
CODE6    AW,K     INERSTEP          BUMP BY INNER LOOP STEP                     
         BDR,N3   ROTATE3           COUNT INNER LOOP                            
*        ...                        COUNT MIDDLE/OUTER LOOPS                    
*        ...                        EXIT                                        
*                                                                               
DELTA    TEMP                       DISTANCE 'TWEEN RTARG/RESULT ELMTS          
IDELTA   TEMP                       INITIAL VALUE FOR DELTA                     
TESTVAL  TEMP                       LOOP COUNT SPECIAL TEST VAL                 
         PAGE                                                                   
*                                                                               
*                                                                               
DTRANS   EQU      %                 DYADIC TRANSPOSE                            
         BAL,LX   LISTCHK           CHECK ARGUMENTS FOR LIST                    
         LI,X     1                                                             
         CB,X    *LFARG,X           LEFT ARG MUST BE VECTOR ...                 
         BNE      ERRANK                                                        
         LB,S    *RTARG,X             ... OF LENGTH EQUAL RIGHT RANK.           
         LW,X     LFARG                                                         
         CW,S     2,X                                                           
         BNE      ERLENGTH                                                      
         STW,S    LFSIZE                                                        
         LI,R     0                                                             
         STW,R    RSRANK            INIT RS RANK = 0                            
         LI,R     INFINITY                                                      
         LCW,X    LFSIZE                                                        
         BEZ      MNOP              NO-OP IF RESULT SCALAR                      
11Z1     STW,R    DBUFEND,X         INIT RS DIMENS = +INF                       
         BIR,X    11Z1                                                          
         BAL,LZ   TRANSVAL          SET UP NX= PTR TO LAST RT DIMEN -1,         
*                                     AND INIT 'GARAYVAL' TO FETCH              
*                                     LEFT ARG VALUES.                          
         B        11Z21                 (DONE)                                  
         AW,AI    ORGADJ            CONVERT NEW LFARG VAL TO ORIGIN 1           
         BLEZ     ERDOMAIN          RANGE CHECK: 1<=VAL<=LFSIZE                 
         CW,AI    RSRANK                                                        
         BLE      11Z2                  RSRANK=MAX(RSRANK,VAL)                  
         STW,AI   RSRANK                                                        
11Z2     SW,AI    LFSIZE            FINISH RANGE CHECK, PREPARE TO              
         BGZ      ERDOMAIN            INDEX INTO DIMENBUF.                      
         LW,R     1,NX              GET CURRENT RT DIMEN                        
         AI,NX    -1                DECR DIMEN PTR                              
         CW,R     DBUFEND-1,AI                                                  
         BGE     *L1                RSDIMEN(VAL) = MIN(RSDIMEN(VAL),            
         STW,R    DBUFEND-1,AI                         RTDIMEN).                
         B       *L1                GO FETCH NEXT VALUE FROM LFARG              
*                                                                               
11Z21    LW,X     RSRANK            LF ARG SCAN DONE. NOW MAKE SURE             
*                                     THE VALUES FORMED A DENSE SET,            
         LI,A     DBUFEND-1           AND COMPUTE RESULT SIZE.                  
         SW,A     LFSIZE                                                        
         LI,NX    DBUFEND-1                                                     
         SW,NX    RSRANK                                                        
         LI,S     1                                                             
11Z3     LW,R    *A,X               IF D(I)=INF, THEN THERE WAS                 
         CI,R     INFINITY                                                      
         BE       ERDOMAIN            A GAP IN LF VALUES.                       
         STW,R   *NX,X              MOVE DIMENS TO END OF DIMENBUF              
         MW,S     R                 SIZE = D(1)*...*D(N)                        
         BDR,X    11Z3                                                          
         STW,S    RSSIZE            STORE RS SIZE                               
         LB,T    *RTARG                                                         
         ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         STW,T    RSTYPE            RESULT TYPE = RIGHT TYPE                    
*                                                                               
*              NOW SET UP THE LOOP CONTROL BLOCK                                
*                                                                               
         LW,S     RSRANK            GET LBLOCK BIG ENOUGH FOR                   
         BAL,L2   INDEXB              N (=RSRANK) B-BLOCKS.                     
         LW,KB    OUTRBLOK                                                      
         LI,R     0                                                             
         LCW,X    RSRANK            INITIALIZE B-BLOCKS:                        
11Z4     LW,S     DBUFEND,X                                                     
         STW,S    BINITCNT,KB           COUNT(J) = D(J)                         
         STW,R    BSTEPVAL,KB           STEP(J)  = 0                            
         EQUAL,0,SEQLOOP                                                        
         STW,R    BLOOPTYP,KB           TYPE(J)  = SEQ                          
         AI,KB    BN                                                            
         BIR,X    11Z4                                                          
         LI,BI    1                 INIT WEIGHT = 1                             
         BAL,LZ   TRANSVAL          SET NX= PNTR TO D(N) -1; INIT               
*                                     'GARAYVAL' TO GET LFARG VALUES.           
         B        ALSELECT            (DONE: ALOC RS, DO SELECTION)             
         SW,AI    ORIGIN            CONVERT NEW LF VALUE TO ORIGIN 0            
         MI,AI    BN                COMPUTE INDEX TO B-BLOCK(VAL),              
         EQUAL,BSTEPVAL,0             AT BSTEPVAL POSITION.                     
         AWM,BI  *OUTRBLOK,AI       ADD WEIGHT TO STEP(VAL)                     
         MW,BI    1,NX              WEIGHT = D(K)*...*D(N)                      
         AI,NX    -1                DECR D(K) PNTR                              
         B       *L1                GO GET NEXT VALUE                           
*                                                                               
*                                                                               
TRANSVAL EQU      %                                                             
         LW,NX    RTARG                                                         
         AW,NX    LFSIZE  (=RTRANK) NX = PTR TO LAST RT DIMEN -1                
         LW,X     LFARG                                                         
         AI,X     2                 X = PTR TO LEFT ARG +RANK+1                 
         LB,T    *LFARG             T = LEFT TYPE                               
         LW,S     LFSIZE            S = LEFT SIZE                               
         B        GARAYVAL,T        BEGIN FETCHING LEFT VALUES; RETURN          
         PAGE                                                                   
*                                                                               
*                                                                               
DEXPAND  EQU      %                 DYADIC EXPAND                               
         LI,OP    DOPCMPRS+1        ALMOST LIKE COMPRESS                        
DCOMPRES EQU      %                 DYADIC COMPRESS                             
         BAL,LX   LISTCHK           CHECK ARGUMENTS FOR LIST                    
         LI,A     0                 SET UP LEFT ARG RANK/SIZE/TYPE              
         BAL,LX   SETUPARG                                                      
         LI,X     1                                                             
         CW,X     LFSIZE            LEFT ARG MUST BE EITHER                     
         BE       15Z0                A 1-ELEMENT ENTITY                        
         CW,X     LFRANK              OR A VECTOR.                              
         BNE      ERRANK                                                        
15Z0     BAL,L2   ST3LUPSN          SET UP LOOP PARAMS FROM RTARG, BUT          
*                                     DON'T ALOC RESULT YET.                    
         LI,NX    0                 SET UP FOR SWEEP THRU                       
         LW,S     LFSIZE              LEFT ARG VALUES.                          
         BEZ      15Z1              IF IT'S NULL, SKIP IT (SUM=0)               
         LW,T     LFTYPE            TYPE                                        
         LW,X     LFARG                                                         
         AW,X     LFRANK                                                        
         AI,X     1                 DATA PNTR                                   
         STW,OP   OPTEMP            SAVE OP VALUE                               
         BAL,LZ   GARAYVAL,T        GET 1ST                                     
         B        15Z01               (DONE)                                    
         AW,NX    AI                ACCUMULATE SUM OF VALUES                    
         CI,AI    -2                NEXT: MAKE SURE IT'S 0 OR 1                 
         BAZ     *L1                GET NEXT                                    
         B        ERDOMAIN                                                      
15Z01    LW,OP    OPTEMP            RESTORE OP VALUE                            
15Z1     LI,S     1                 DONE: NX = SUM OF LFARG VALUES              
         CW,S     RTSIZE            IS RTARG A 1-ELEMENT THING ?                
         BNE      15Z2              NO                                          
         EXU      OPTBL1,OP         YES, SET RESULT SIZE                        
         STW,NX   RSSIZE              = SUM (COMPRESS), OR                      
         LW,T     RTTYPE              = LEFT SIZE (EXPAND).                     
         BAL,L2   VECTORRS          ALOC RS = VECTOR                            
         B        15Z9              GO GEN XSEG CODE                            
15Z2     CW,S     LFSIZE            RTARG NORMAL: IS LFARG                      
         BNE      15Z6,OP             A 1-ELEMENT THING ?                       
         B        15Z3,NX           YES, WHAT IS ITS VALUE ?                    
15Z3     B        15Z4,OP           0: SPECIAL CASE FOR COMPRESS                
         B        MNOP              1: RESULT = RTARG                           
15Z4     TABLE    DOPCMPRS          LFARG = 0 (1-ELEMENT)                       
         B        15Z8              COMPRESS: TREAT AS IF LFSIZE=D(K)           
15Z5     CW,NX    MIDLCNT           EXPAND: MAKE SURE THAT                      
         BNE      ERLENGTH            D(K) =  +/(LEFT ARG)                      
         LW,NX    LFSIZE              AND SET M = LEFT SIZE.                    
         B        15Z8                                                          
15Z6     TABLE    DOPCMPRS          BOTH ARGS NORMAL.  WHAT OP ?                
         B        15Z7              COMPRESS                                    
         B        15Z5              EXPAND                                      
15Z7     LW,S     LFSIZE            COMPRESS: MAKE SURE THAT                    
         CW,S     MIDLCNT             D(K) = LEFT SIZE                          
         BNE      ERLENGTH            AND USE M = +/(LEFT ARG).                 
15Z8     SW,NX    MIDLCNT           IF M=D(K),                                  
         BEZ      MNOP                RESULT= RTARG.                            
         STW,NX   DELTA             SAVE M-D(K)                                 
         LW,L2    RTSIZE            SAVE ACTUAL ARG    SIZE                     
         MW,NX    OUTRCNT           RESULT SIZE DIFFERS FROM RT SIZE BY         
         MW,NX    INERCNT             D(1)*...*D(K-1)*(M-D(K))*                 
         AWM,NX   RTSIZE                      *D(K+1)*...*D(N).                 
         BAL,L1   RSLIKERT          ALOC ARG    LIKE RTARG (EXCEPT              
         STW,L2   RTSIZE            RESTORE ARG    SIZE                         
         BAL,LX   MRTDIMS             FOR SIZE); COPY RT DIMENS.                
         LW,K     COORDK            CHANGE K'TH DIMEN OF RESULT                 
         AI,K     1                   FROM D(K) TO M BY ADDING                  
         LW,R     DELTA               D(K)-M TO IT.                             
         AWM,R   *RESULT,K                                                      
15Z9     BAL,L1   SETN1KN           SET UP LFADR FOR SEQ ACCESS (N1),           
*                                          RTADR FOR IND ACCESS (K),            
*                                      AND RSADR FOR SEQ ACCESS (N).            
         BAL,LX   GXSEGINI          INIT XSEG; EXIT IF RESULT NULL              
         GEN,0,4  CODE12            GEN LOOP INIT CODE                          
         LI,T     LOGL              SET TO CONVERT LFARG TO LOGL                
         STW,T    RSTYPE                                                        
         LI,A     0                 GEN LOAD/CONVERT LEFT ARG ELMT              
         BAL,L1   GENLOAD                                                       
         GEN,0,2  CODE14            GEN TEST/INNER LOOP INIT                    
         STW,XL   LOOPLOC           REMEMBER INNER LOOP LOC                     
         LW,T     RTTYPE                                                        
         LW,R     LOADINST,T        GEN LOAD (RIGHT),                           
         AW,R     RTADR                                                         
         ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         LW,R+1   STORINST,T            STORE,                                  
         AW,R+1   RSADR                                                         
         GEN,2,2  R,CODE15              AND LOOP CONTROL CODE.                  
         LI,S     1                                                             
         LW,OP    OPTEMP            RESTORE OP CODE AGAIN                       
         CW,S     RTSIZE            IF RTARG IS 1-ELEMENT,                      
         BNE      15Z10,OP            MODIFY CODE TO EXCLUDE                    
         MTW,1    -2,XL               K-INCREMENTS.                             
         MTW,1    -6,XL                                                         
         B        15Z10,OP                                                      
15Z10    TABLE    DOPCMPRS                                                      
         B        15Z11             COMPRESS: XSEG COMPLETED                    
         LI,AF1   X'1FFFF'          EXPAND: CHANGE TEST INST                    
         LW,AF    XL                  ADR FROM COMPRES2 TO HERE.                
         STS,AF   -6,XL                                                         
         LW,R     CODE17              GEN INNER LOOP                            
         LW,T     RTTYPE              WHICH STORES NULL ELEMENTS                
         ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         LW,R+1   NULLINST,T          IN RESULT.                                
         LW,R+2   STORINST,T                                                    
         AW,R+2   RSADR                                                         
         GEN,3,2  R,CODE18                                                      
*                                                                               
15Z11    LW,R     LFLGLADR          FETCH LOGL PARAMS FOR USE TO                
         LW,R+1   LFLGLCNT            RE-INIT LOGL.                             
         B        EXECUTE           EXECUTE XSEG                                
*                                                                               
*                                                                               
OPTBL1   TABLE    DOPCMPRS          EXU TABLE - BY OP:                          
         NOP                        COMPRESS                                    
         LW,NX    LFSIZE            EXPAND                                      
*                                                                               
OPTEMP   TEMP                       TEMP FOR OP CODE                            
*                                                                               
*                                                                               
NULLINST TABLE    LOGL              LOAD NULL INST - BY TYPE:                   
         LI,AI    0                 LOGL                                        
         LI,AI    ' '               CHAR                                        
         LI,AI    0                 INTG                                        
         LD,AF    FLOT0             FLOT                                        
*                                                                               
*                                                                               
*              XSEG CODE:                                                       
*                                                                               
*        LCW,N    RSSIZE         0  INIT STORE INDEX                            
CODE12   LI,K     0              1  INIT RTARG FETCH INDEX                      
         STW,R    LFLGLADR       2  RESTORE INITIAL LOGL PARAMS                 
         STW,R+1  LFLGLCNT       3                                              
         LCW,N1   LFSIZE         4  INIT MIDDLE LOOP                            
*        LOAD/CNV LFARG(N1)      5  LOAD LFARG VALUE (0 OR 1)                   
CODE14   BEZ      COMPRES2          IF ZERO, GO TO SKIP (NULL-FILL) CODE        
         LW,N2    INERCNT           ONE: INIT INNER LOOP                        
*LOOPLOC LOAD     RTARG(K)          COPY RTARG ELMTS TO RESULT                  
*        STORE    RESULT(N)                                                     
CODE15   BIR,N    COMPRES1          COUNT RESULT                                
         B       *RETURN            EXIT WHEN FILLED                            
COMPRES1 AI,K     1              *  BUMP FETCH INDEX                            
         BDR,N2  *LOOPLOC        *  COUNT INNER LOOP                            
         BIR,N1   XSEGBASE+5     *  COUNT MIDDLE LOOP                           
         B        EXPAND3        *  RE-START IF APPROPRIATE                     
*                                                                               
COMPRES2 AW,K     INERCNT        *  ZERO: SKIP OVER INNER LOOP                  
         BIR,N1   XSEGBASE+5     *  COUNT MIDDLE LOOP                           
         B        EXPAND3        *  RE-START IF APPROPRIATE                     
*        ...OR...                                                               
CODE17   LW,N2    INERCNT           ZERO: INNER LOOP ...                        
*LOOP4   LOAD     NULL                COPIES NULLS                              
*        STORE    RESULT(N)           TO RESULT.                                
CODE18   BIR,N    EXPAND2           COUNT RESULT                                
         B       *RETURN            EXIT WHEN FILLED                            
EXPAND2  BDR,N2   -4,XL   (LOOP4)*  COUNT INNER LOOP                            
         BIR,N1   XSEGBASE+5     *  COUNT MIDDLE LOOP                           
EXPAND3  CW,N     DELRSIZE       *  IF RESULT IS CHAR, DON'T TRY                
         BGE     *RETURN         *    TO FILL OUT TRAILING GAP.                 
         B        XSEGBASE+2     *  RE-START                                    
         PAGE                                                                   
*                                                                               
*                                                                               
DTAKE    EQU      %                 DYADIC TAKE                                 
DDROP    EQU      %                 DYADIC DROP                                 
         STW,OP   OPTEMP            SAVE OP CODE                                
         LI,A     1                 SET UP RIGHT ARG'S RANK/SIZE/TYPE,          
         BAL,LX   SETUPARG            CONVERTING ISEQ TO INTG VECTOR.           
         LW,X     LFARG             GET LFARG POINTER                           
         LI,NX    1                                                             
         CB,NX   *LFARG,NX          LEFT ARG MUST BE EITHER                     
         BL       ERRANK                                                        
         BG       17Z0                A SCALAR,                                 
         AI,X     1                   OR A VECTOR OF LENGTH                     
         LW,NX    1,X                 = RIGHT ARG RANK.                         
17Z0     STW,NX   LFSIZE            SAVE LEFT ARG SIZE                  10-00008
         LI,R     =1                IF RT ARG SCALAR, SET 'ARGDIMPT'    10-00009
         LW,L3    RTRANK              TO POINT TO '1' AND L3=0;         U10-0074
         BEZ      17Z01               OTHERWISE, 'ARGDIMPT' POINTS      10-00011
*                                     TO ARG DIMENS, L3=-1 TO BUMP IT.  U10-0076
         CW,NX    RTRANK            RT ARG NOT SCALAR: LF ARG SIZE      10-00013
*                                     MUST AGREE.                       10-00014
         BNE      ERLENGTH                                                      
         LW,R     RTARG             SET UP TO ACCESS RT ARG                     
         AW,R     RTRANK              DIMENS D(N),...,D(1).             10-00016
         AI,R     1                                                     10-00017
         LI,L3    -1                ..TO BUMP DIMEN PTR                 10-00018
17Z01    STW,R    ARGDIMPT                                              10-00019
         LB,T    *LFARG                                                         
         LI,BI    1                 INIT RS SIZE                                
         AI,X     1                 POINT TO LF DATA -1                         
         LW,S     LFSIZE            GET SIZE OF LF ARG                  10-00021
         BNEZ     17Z1,OP           ENTER TAKE/DROP LOOP UNLESS LFSIZE=         
         B        MNOP                =RTRANK=0, IN WHICH CASE, DO NO-OP.       
17Z1     TABLE    DOPTAKE                                                       
         B        17Z4              TAKE                                        
         BAL,LZ   GARAYVAL,T        DROP: GET A(N) VALUE                        
         B        17Z6                (DONE)                                    
         STW,AI   DIMENBUF,NX         SAVE IT IN DIMEN BUF                      
         BGEZ     17Z2                J'TH RESULT DIMEN R(J)                    
         AW,AI   *ARGDIMPT            = MAX(0,D(J)-ABS(A(J))).          10-00023
         BGEZ     17Z3                                                  10-00024
         B        17Z21                                                 10-00025
17Z2     SW,AI   *ARGDIMPT           AI = +-R(J)                        10-00026
         BLEZ     17Z3                                                  10-00027
17Z21    LI,AI    0                                                     10-00028
17Z3     MW,BI    AI                  ACCUMULATE +-RSSIZE                       
         BNOV     17Z5                  = +-R(1)*...*R(N); GET NEXT A(J)        
         B        ERDOMAIN                                                      
17Z4     BAL,LZ   GARAYVAL,T        TAKE: GET A(N) VALUE                        
         B        17Z6                (DONE)                                    
         STW,AI   DIMENBUF,NX         SAVE IT IN DIMEN BUF                      
         MW,BI    AI                  R(J) = ABS(A(J)); ACCUM +-RSSIZE          
         BOV      ERDOMAIN              = +-A(1)*...*A(N).                      
17Z5     AWM,L3   ARGDIMPT          BUMP DIMEN POINTER                  10-00030
         BDR,NX  *L1                REDUCE J, GET NEXT A(J)             10-00031
17Z6     LW,OP    OPTEMP            DONE, RESTORE OP CODE                       
         LAW,S    BI                RSSIZE = R(1)*...*R(N)                      
         STW,S    RSSIZE                                                        
         LW,T     RTTYPE            RESULT TYPE/RANK                            
         ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         STW,T    RSTYPE              = RTARG TYPE/RANK.                        
         LW,R     LFSIZE                                                10-00033
         STW,R    RSRANK                                                        
         BAL,L1   ALOCRS            ALOC RS DATA BLOCK                          
         LW,S     RSRANK            ALOC LOOP CONTROL BLOCK                     
         BAL,L2   INDEXB              AND INIT LOOP PARAMS.                     
         AI,L3    0                 IF RT ARG NOT SCALAR,               10-00035
         BEZ      17Z7                RE-INIT ARG DIMEN PTR.            10-00036
         LW,R     RTARG                                                         
         AW,R     RTRANK                                                10-00038
         AI,R     1                                                     10-00039
         STW,R    ARGDIMPT            THE D(J)                                  
17Z7     EQU      %                                                     10-00041
         LW,R     RESULT              AND THE R(J).                             
         AI,R     1                                                             
         STW,R    DIMENPTR                                                      
         LW,X     RSRANK            INIT LOOP: J=N;                             
         LW,KB    INERBLOK            INNERMOST B-BLOCK;                        
         LI,AI    1                   NULL COUNT = R(J+1)*...*R(N);             
         LI,BI    1                   WEIGHT = D(J+1)*...*D(N).                 
*                                                                               
*     SET UP LOOP CONTROL BLOCK AND RESULT DIMENS                               
*                                                                               
17Z8     LAW,S    DIMENBUF,X        GET ABS(A(J))                               
         B        17Z9,OP           WHICH OP?                                   
17Z9     TABLE    DOPTAKE                                                       
         B        17Z10             TAKE                                        
         LCW,S    S                 DROP: COMPUTE R(J)=D(J)-ABS(A(J))           
         AW,S    *ARGDIMPT                                              10-00043
         BGEZ     17Z91             IF D(J)<ABS(A(J)),                  10-00044
         LI,S     0                   R(J)=0.                           10-00045
17Z91    EQU      %                                                     10-00046
         STW,S   *DIMENPTR,X          STORE R(J) IN RESULT DIMEN                
         STW,S    BINITCNT,KB         COUNT OF LOOP(J) = R(J)                   
         LW,S     DIMENBUF,X          GET A(J); IF A(J)>0,  INCREASE            
         BGZ      17Z13                 FIXED-PART VAL BY A(J)*WEIGHT.          
         B        17Z14                                                         
17Z10    STW,S   *DIMENPTR,X        TAKE: R(J)=ABS(A(J)); STORE IT AS           
         STW,S    BINITCNT,KB           RESULT DIMEN AND LOOP COUNT.            
         LW,S     DIMENBUF,X          GET A(J)                                  
         BLZ      17Z12               A(J)<0: BRANCH                            
         CW,S    *ARGDIMPT          A(J)>=0: COMPARE WITH D(J)          10-00048
         BLE      17Z14                                                         
         LW,S     =X'7FFFFFFF'        A(J)>D(J): SPECIFY 'D(J) ELEMENTS         
         SW,S    *ARGDIMPT            FOLLOWED BY A(J)-D(J) NULLS'.     10-00050
17Z11    STW,S    NULTSBUF,X          SET UP 'MIXED SEQUENCE' LOOP:             
         STW,AI   NULCTBUF,X          NULL-TEST VAL IN 'NULTSBUF' AND           
         LI,S     MIXLOOP             NULL GROUP COUNT IN 'NULCTBUF'.           
         STB,X    S                   INCLUDE BUFFER INDEX IN OP CODE WORD.     
         B        17Z15                                                         
17Z12    AW,S    *ARGDIMPT          A(J)<0: COMPUTE A(J)+D(J)           10-00052
         BLZ      17Z11               A(J)<-D(J): SPECIFY '-D(J)-A(J)           
*                                       NULLS, FOLLOWED BY D(J) ELMTS'.         
17Z13    MW,S     BI                INCR FIXED PART VAL BY A(J)*WEIGHT          
         AWM,S    FVALUE              (DROP) OR (A(J)+D(J))*WEIGHT (TAKE        
17Z14    LI,S     SEQLOOP           LOOP TYPE = ORDINARY SEQUENCIAL             
17Z15    STW,S    BLOOPTYP,KB                                                   
         STW,BI   BSTEPVAL,KB       STEP VALUE =WEIGHT=D(J+1)*...*D(N)          
         MW,BI   *ARGDIMPT          UPDATE WEIGHT FACTOR (NO OVFL POSS) 10-00054
         MW,AI   *DIMENPTR,X        UPDATE NULL COUNT =R(J+1)*...*R(N)          
         AI,KB    -BN               POINT TO NEXT OUTER B-BLOCK                 
         AWM,L3   ARGDIMPT          BUMP DIMEN PNTR (IF NOT SCALAR)     10-00056
         BDR,X    17Z8              DECR J, DO NEXT COORD                       
*                                                                               
*     COORD LOOP DONE.  NOW BUILD AND EXECUTE XSEG                              
*                                                                               
         LI,A     1                 SET RTARG FOR INDICIAL LOAD                 
         BAL,LX   XSETUP                                                        
         LI,X     -1                SET RESULT FOR SEQUENTIAL STORE             
         BAL,LX   SETADR                                                        
         BAL,LX   GXSEGINI          INIT XSEG; EXIT IF RESULT NULL              
         GEN,0,2  CODE20            GEN LOOP INIT CODE                          
         LW,T     RTTYPE                                                        
         LW,R     LOADINST,T        GEN LOAD,                                   
         AW,R     RTADR                                                         
         ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         LW,R+1   STORINST,T            STORE,                                  
         AW,R+1   RSADR                                                         
         GEN,2,2  R,CODE21              LOOP CONTROL CODE.                      
         AI,OP    -DOPTAKE          IF IT'S 'DROP', THE XSEG IS FINISHED        
         BNEZ     EXECUTE                                                       
         LW,R     NULLINST,T        TAKE: GEN ADDITIONAL CODE                   
         GEN,2,4  R,CODE22            TO COPY NULLS TO RESULT.                  
         B        EXECUTE                                                       
*                                                                               
*                                                                               
*              XSEG CODE:                                                       
*                                                                               
*        LCW,N    RSSIZE         0  INIT STORE INDEX                            
CODE20   LI,L2    XSEGBASE+7     1  SET NULL-COPY ADR (FOR 'TAKE' ONLY)         
         BAL,L1   1STSCRPT       2  GET 1ST LOAD INDEX                          
*        LOAD     RTARG(K)       3  COPY SELECTED ELEMENT                       
*        STORE    RESULT(N)      4    TO RESULT.                                
CODE21   BIR,N    NXTSCRPT       5  BUMP STORE INDEX; GET NEXT LOAD INDX        
         B       *RETURN         6  EXIT WHEN RESULT FULL                       
*        LOAD     NULL           7  COPY NULL ELEMENT                           
*        STORE    RESULT(N)      8    TO RESULT.                                
CODE22   BIR,N    XSEGBASE+11    9  BUMP STORE INDEX                            
         B       *RETURN        10  EXIT WHEN DONE                              
         BDR,N2   XSEGBASE+7    11  COUNT NULLS                                 
         B        NXTSCRPT      12  RETURN FOR NEXT LOAD INDEX VALUE            
*                                                                               
NULTSBUF EQU      INBUF+0           NULL-TEST VALUE BUFFER                      
NULCTBUF EQU      INBUF+64          NULL-GROUP COUNT BUFFER                     
         PAGE                                                                   
*                                                                               
*                                                                               
DCATEN   EQU      %                 DYADIC CATENATE                             
         LI,X     1                                                             
         LB,R    *LFARG,X                                                       
         CB,R    *RTARG,X           PLACE HIGHER RANKED                         
         BLE      18Z0                ARG IN RTARG                              
         EXCHANGE ARGS                                                          
         AI,OP    -1**17            IF ARGS SWAPPED, SET OP'S SIGN BIT          
18Z0     LI,A     0                                                             
         BAL,LX   SETUPARG          SET LFRANK/SIZE/TYPE                        
         LI,A     1                                                             
         BAL,LX   SETUPARG          SET RTRANK/SIZE/TYPE                        
         BAL,LX   TYCOMPAT          CHECK COMPATIBILITY; SET RS TYPE            
         B        18Z02            GO RESOLVE NUMERIC VS TEXT                   
18Z01    LW,S     LFSIZE                                                        
         AW,S     RTSIZE            RESULT SIZE = SUM OF ARG SIZES              
         STW,S    RSSIZE                                                        
         LW,R     RTRANK            SET RESULT RANK                             
         STW,R    RSRANK              = HIGHEST ARG RANK.                       
         BNEZ     18Z1              ARE BOTH ARGS SCALARS?                      
         BAL,L2   VECTORRS          YES: ALOC VECTOR RESULT (SIZE=2)            
         LI,R     1                 SET COUNTS TO 1                             
         STW,R    LFCOUNT                                                       
         STW,R    RTCOUNT                                                       
         B        18Z12             JOIN MAIN CASE                              
18Z02    LW,S     LFSIZE           IS 'LFARG' EMPTY...                          
         BEZ      18Z03              YES, USE TYPE OF 'RTARG'                   
         LW,T     LFTYPE             NO, SET FOR TYPE OF 'LFARG'                
         LW,S     RTSIZE           IS 'RTARG' EMPTY...                          
         BEZ      18Z04              YES, USE TYPE OF 'LFARG'                   
         B        ERDOMAIN            NO, CONFLICT-- DOMAIN ERROR               
18Z03    LW,T     RTTYPE           SET FOR TYPE OF 'RTARG'                      
18Z04    ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         STW,T    RSTYPE                                                        
         B        18Z01              OF (HOPEFULLY) NON-EMPTY ARG               
18Z1     LB,K     OPER+1            CHECK LAMINATION BIT                        
         CI,K     LAMBIT                                                        
         BAZ      18Z2              OFF (CATENATION)                            
         AI,OP    2                 ON  (LAMINATION): MODIFY OP CODE            
         AI,K     -LAMBIT+1         GET RID OF LAM. BIT, BUMP COORD             
         STB,K    OPER+1              SPEC TO CEILING OF GIVEN COORD.           
         LW,S     RTSIZE            SET RESULT SIZE                             
         SLS,S    1                   =2* RIGHT ARG SIZE.                       
         STW,S    RSSIZE                                                        
         LW,R     LFRANK                                                        
         BEZ      18Z15             UNLESS LFARG IS SCALAR,                     
         CW,R     RTRANK              ARG RANKS MUST AGREE                      
         BNE      ERRANK                                                        
18Z15    MTW,1    RSRANK            RESULT RANK IS 1 HIGHER                     
         CW,K     RSRANK            COMPARE WITH K                              
         BL       18Z17             K<=ARG RANK: 'ST3LUPSN' WILL WORK           
         BNE      ERCOORD           K> ARG RANK+1: ERROR                        
         STW,K    COORDK            K= ARG RANK+1: SIMULATE ST3LUPSN            
         LI,A     1                                                             
         STW,A    MIDLCNT                                                       
         STW,A    MIDLSTEP                                                      
         STW,A    OUTRSTEP                                                      
         B        18Z6              JOIN OTHER CASE                             
18Z17    BAL,L2   ST3LUPSN          SET LOOP PARAMS; CHECK K                    
         B        18Z6                                                          
18Z2     LW,R     LFRANK            EITHER LFARG IS SCALAR,                     
         BEZ      18Z3                                                          
         CW,R     RTRANK              OR RANKS AGREE,                           
         BE       18Z4                                                          
         AI,R     1                   OR THEY MUST DIFFER BY 1.                 
         CW,R     RTRANK                                                        
         BNE      ERRANK                                                        
18Z3     AI,OP    1                 MODIFY OP TO SAY 'DIFFERENT RANKS'          
18Z4     BAL,L2   ST3LUPSN          SET LOOP PARAMS FOR RTARG; CHECK K;         
         LW,R     LFRANK            IF LFARG ISN'T SCALAR,                      
         BNEZ     18Z6                WE'VE ALREADY GOT RSSIZE.                 
         LW,S     OUTRCNT           IF IT IS, WE MUST SET                       
         MW,S     INERCNT             RSSIZE = D(1)*...                         
         BOV      ERLENGTH                                              10-00063
         AW,S     RTSIZE              *(D(K)+1)*...*D(N).                       
         BOV      ERLENGTH                                              10-00065
         STW,S    RSSIZE                                                        
18Z6     LW,S     RSSIZE            GENERAL CASE:                               
         BAL,L1   ALOCRS            ALOC RS DATA BLOCK                          
         LW,X     RSRANK            SET UP TO SCAN DIMENS                       
         B        18Z7,OP                                                       
18Z7     TABLE    DOPCATEN          MODIFY PNTR(S) - BY OP:                     
         MTW,1    LFARG             CAT, RANKS SAME: ALIGN PNTRS                
         MTW,1    RTARG             CAT, RANKS DIFF: OFFSET PNTRS               
         MTW,1    RESULT            LAM: PNTRS ALIGNED, 1 LOW                   
18Z8     LW,R    *RTARG,X           DIMEN LOOP: GET D(I)                        
         CW,X     COORDK            IS I=K ?                                    
         BNE      18Z13             NO, GO CHECK C(I)=D(I)                      
         EXU      OPTBL2,OP         YES, COMPUTE VALUE OF LEFT COUNT            
         MW,S     MIDLSTEP            NOW, WHILE C(K) AND D(K)                  
         STW,S    LFCOUNT             ARE HANDY.                                
         EXU      OPTBL3,OP         COMPUTE K'TH RESULT DIMEN                   
         B        18Z9,OP           DO APPROPRIATE PNTR MODIFY                  
18Z9     TABLE    DOPCATEN                                                      
         B        18Z11             CAT, RANKS SAME: PNTRS ALIGNED              
         B        18Z10             CAT, RANKS DIFF: ALIGN ARG PNTRS            
         MTW,1    RTARG             LAM: CORRECT FOR 1 EXTRA RS DIMEN           
18Z10    MTW,1    LFARG                                                         
18Z11    STW,R   *RESULT,X          STORE I'TH RESULT DIMEN                     
         BDR,X    18Z8              COUNT DIMEN LOOP                            
         MTW,-1   LFARG             DONE: RESTORE PNTRS                         
         MTW,-1   RTARG                                                         
         MTW,-1   RESULT                                                        
18Z12    STW,OP   OPTEMP            SAVE OP CODE                                
         BAL,L1   SETN1KN           SET ADDRESSES                               
         BAL,LX   GXSEGINI          PREPARE TO GEN XSEG CODE                    
         LW,A     LFRANK            IF LFARG IS SCALAR                          
         BNEZ     18Z16               GEN LOAD/CONVERT OF                       
         BAL,L2   GENLOADT            LFARG TO ITS TEMP.                        
18Z16    GEN,0,5  CODE23A           GEN LOOP INIT CODE                          
         STW,XL   LFLOOP            SAVE LOC OF LEFT ARG LOOP                   
         LI,A     0                                                             
         BAL,L1   GENLOAD           GEN LOAD/CONVERT OF LFARG(N1)               
         LW,T     RSTYPE                                                        
         LW,R     STORINST,T        GEN STORE RESULT(N)                         
         AW,R     RSADR                                                         
         STW,R    TEMP                                                          
         GEN,1,2  R,CODE23          GEN LOOP CONTROL                            
         STW,XL   RTLOOP            SAVE LOC OF RIGHT ARG LOOP                  
         LI,A     1                                                             
         BAL,L1   GENLOAD           GEN LOAD/CONVERT OF RTARG(K)                
         LW,R     TEMP              GEN STORE RESULT(N),                        
         GEN,1,2  R,CODE24              LOOP CONTROL                            
         B        EXECUTE           EXECUTE XSEG                                
18Z13    CW,R    *LFARG,X           DIMEN LOOP: FOR I/=K, WE                    
         BE       18Z11               REQUIRE C(I)=D(I).                        
         LW,S     LFRANK            DONT ACTUALLY DO COMPARISON                 
         BEZ      18Z11               IF LFARG IS SCALAR.                       
         CW,X     COORDK              ERROR,IF I>K,PNTRS ARE STILL AS   10-00059
         BG       18Z14,OP            INITIALIZED, AND MUST BE SELECT-          
*                                     IVELY FIXED. IF I<K, THEY'RE              
18Z14    TABLE    DOPCATEN            ALL OFF BY 1.                             
         MTW,-1   LFARG                                                         
         MTW,-1   RTARG                                                         
         MTW,-1   RESULT                                                        
         B        ERLENGTH          REPORT ERROR                                
*                                                                               
*              XSEG CODE:                                                       
*                                                                               
*        LCW,N    RSSIZE            INIT STORE INDEX                            
*        LOAD/CNV LFARG             PUT LFARG IN TEMP (ONLY IF                  
*        STORE    LFTEMP              IT'S SCALAR).                             
CODE23A  LCW,N1   LFSIZE            INIT LEFT FETCH INDEX                       
         LI,K     0                 INIT RIGHT FETCH INDEX                      
         LW,OP    OPTEMP            WERE ARGS SWAPPED ?                         
         BGZ      CATEN4            NO, START WITH LEFT LOOP                    
         B        CATEN2            YES, START WITH RIGHT LOOP                  
*LFLOOP  LOAD/CNV LFARG(N1)         MOVE LEFT ARG ELMTS                         
*        STORE    RESULT(N)           TO RESULT.                                
CODE23   BIR,N    CATEN1            COUNT RESULT                                
         B       *RETURN            EXIT WHEN FILLED                            
CATEN1   AI,N1    1              *  BUMP AND                                    
         BDR,N2  *LFLOOP         *    COUNT LEFT LOOP.                          
CATEN2   CW,N     DELRSIZE       *  IF RESULT IS CHAR, DON'T TRY                
         BGE     *RETURN         *    TO FILL OUT TRAILING GAP.                 
         LW,N2    RTCOUNT        *  INIT RIGHT LOOP                             
         BNEZ    *RTLOOP         *  GO TO RIGHT LOOP                            
         B        CATEN4         *  RTCOUNT=0, GO TO LEFT LOOP                  
*RTLOOP  LOAD/CNV RTARG(K)          MOVE RIGHT ARG ELMTS                        
*        STORE    RESULT(N)           TO RESULT.                                
CODE24   BIR,N    CATEN3            COUNT RESULT                                
         B       *RETURN            EXIT WHEN FILLED                            
CATEN3   AI,K     1              *  BUMP AND                                    
         BDR,N2  *RTLOOP         *    COUNT RIGHT LOOP.                         
CATEN4   CW,N     DELRSIZE       *  IF RESULT IS CHAR, DON'T TRY                
         BGE     *RETURN         *    TO FILL OUT TRAILING GAP.                 
         LW,N2    LFCOUNT        *  INIT LEFT  LOOP                             
         BNEZ    *LFLOOP         *  GO TO LEFT LOOP                             
         B        CATEN2         *  LFCOUNT=0, GO TO RIGHT LOOP                 
*                                                                               
*                                                                               
LFCOUNT  TEMP                       LEFT LOOP COUNT                             
RTCOUNT  EQU      OUTRSTEP          RIGHT LOOP COUNT (SET BY ST3LUPSN)          
LFLOOP   TEMP                       LEFT ARG LOOP LOC                           
RTLOOP   EQU      LOOPLOC           RIGHT ARG LOOP LOC                          
*                                                                               
*                                                                               
OPTBL2   TABLE    DOPCATEN          LFCOUNT COMPUTATION - BY OP:                
         LW,S    *LFARG,X           CAT, RANKS SAME: C(K)*D(K+1)*...            
         LI,S     1                 CAT, RANKS DIFF:    1*D(K+1)*...            
         LW,S     MIDLCNT           LAM:             D(K)*D(K+1)*...            
*                                                                               
OPTBL3   TABLE    DOPCATEN          K'TH RS DIMEN COMPUTATION - BY OP:          
         AW,R    *LFARG,X           CAT, RANKS SAME: C(K)+D(K)                  
         AI,R     1                 CAT, RANKS  DIFF:   1+D(K)                  
         LI,R     2                 LAM: (EXTRA DIMEN)= 2                       
         PAGE                                                                   
*                                                                               
*                                                                               
*  I N D E X I N G    S E T U P    R O U T I N E S                              
*                                                                               
*                                                                               
*  BUILD L-BLOCK FROM SUBSCRIPT LIST                                            
*                                                                               
*              THIS SUBROUTINE ANALYSES THE SUBSCRIPT LIST (PNTR                
*              IN 'SCRIPT') AND BUILDS A LOOP CONTROL BLOCK SUITABLE            
*              FOR USE BY 'NXTSCRPT'.  THE STRUCTURE OF THIS BLOCK              
*              IS AS FOLLOWS:                                                   
*                                                                               
*                   1. B (ONE 6-WORD BLOCK PER SCRIPT).  EACH B-BLOCK           
*                      HAS ONE OF THE FOLLOWING FORMATS. DEPENDING ON           
*                      THE SCRIPT STRUCTURE:                                    
*                                                                               
*                      NULL:   STEP,   SIZE, -, -, -, 0                         
*                      ISEQ:   STEP,   SIZE, -, -, -, 0                         
*                      SCALAR: ---------NONE-----------                         
*                      ARRAY:  VPNTR,  SIZE, -, -, -, -1                        
*                                                                               
*                      WHERE VPNTR = OFFSET INTO V-BLOCK WHERE SCRIPT           
*                                    VALUES ARE LOCATED.                        
*                                                                               
*                   2. V (VARIABLE LENGTH): CONTAINS SCRIPT VALUES              
*                      FOR ALL ARRAY SCRIPTS.                                   
*                                                                               
*              THE RESULT DIMENSIONS (= ALL THE SCRIPT DIMENS,                  
*              CATENATED) ARE PLACED IN THE DIMENSION BUFFER.                   
*              EACH SCRIPT PLACES STUFF IN THE DIMEN BUFFER                     
*              AS FOLLOWS:                                                      
*                                                                               
*                      NULL:   SIZE OF CURRENT DIMEN                            
*                      ISEQ:   SIZE                                             
*                      SCALAR: NOTHING                                          
*                      ARRAY:  ARRAY DIMENS                                     
*                                                                               
*              THE ORIGINAL SCRIPT LIST POINTER IS DE-REFFED, AND THE           
*              NEW L-BLOCK POINTER IS PLACED IN 'LBLOCK'.                       
*              THIS ROUTINE ALSO ESTABLISHES RESULT SIZE AND RANK               
*              IN RSRANK/RSSIZE.  LINK IS L2.                                   
*                                                                               
*                                                                               
INDEXA   EQU      %                                                             
         LI,S     0                                                     U10-0078
         STW,S    RSRANK            INIT SCRIPT RANK TO ZERO            U10-0079
*                                                                       U10-0080
*     TEST FOR SPECIAL CASE: VECTOR ARG WITH SCALAR SUBSCRIPT           U10-0081
*                                                                       U10-0082
         STW,S    OLDLBLOK          SET OLDLBLOK = LBLOCK (=0)          U10-0083
*                                     FOR UPDATELP.                     U10-0084
         STW,S    INERBLOK          SET INERBLOK<OUTRBLOK FOR 1STSCRPT  U10-0085
         LI,A     1                                                     U10-0086
         STW,A    OUTRBLOK                                              U10-0087
         STW,A    RSSIZE            INIT SCRIPT SIZE TO 1               U10-0088
         LW,X     SCRIPT            IN ORDER TO HAVE THE SPECIAL CASE,  U10-0089
         CW,A     2,X                 THERE MUST BE EXACTLY 1 SCRIPT,   U10-0090
         BNE      1Z0                                                   U10-0091
         CB,A    *RTARG,A             THE IND.VAR. MUST BE A VECTOR,    U10-0092
         BNE      ERRANK                                                U10-0093
         LW,X     3,X                 AND THE SCRIPT                    U10-0094
         BEZ      1Z0                 (NOT ELIDED)                      U10-0095
         LB,R    *X,A                 MUST BE A SCALAR.                 U10-0096
         BNEZ     1Z0                                                   U10-0097
*                                                                       U10-0098
*     SPECIAL CASE: NO LOOP CONTROL BLOCK NEEDED                        U10-0099
*                                                                       U10-0100
         LB,T    *X                                                     U10-0101
         BAL,LZ   GSCLRVAL,T        GET SUBSCRIPT VALUE                 U10-0102
         SW,AI    ORIGIN            CONVERT TO ORIGIN-0                 U10-0103
         BLZ      ERINDEX           REQUIRE:                            U10-0104
         LW,A     RTARG               0<=SCRIPT<DIMEN                   U10-0105
         CW,AI    2,A                                                   U10-0106
         BGE      ERINDEX                                               U10-0107
         STW,AI   FVALUE            THAT'S THE WHOLE SCRIPT             U10-0108
         B        DREFSCR           DE-REF SCRIPT, EXIT                 U10-0109
1Z0      EQU      %                                                     U10-0110
*                                                                       U10-0111
*     GENERAL CASE: COMPUTE SIZE OF LOOP CONTROL BLOCK, ALLOCATE IT     U10-0112
*                                                                       U10-0113
         STW,S    BLENGTH                                                       
         STW,S    VLENGTH                                                       
         LW,X     SCRIPT            CREATE POINTER TO SCRIPT LIST +2            
         AI,X     2                   (WORD BEFORE 1ST SUBSCRIPT PNTR)          
         STW,X    SCRIPT2                                                       
         LW,NX   *SCRIPT2           GET NUMBER OF SUBSCRIPTS                    
1Z1      LW,X    *SCRIPT2,NX        GET SCRIPT PNTR (STARTING WITH LAST)        
         BNEZ     1Z3               IS IT ZERO (I.E., NULL) ?                   
1Z2      MTW,1    RSRANK            YES, NULL/ISEQ: INCREASE RANK BY 1          
         MTW,BN   BLENGTH             AND RESERVE ONE ITEM FOR B-BLOCK.         
         BDR,NX   1Z1               SCAN NEXT SUBSCRIPT                         
         B        1Z5               DONE                                        
1Z3      LI,T     ISEQ              NOT NULL, IS IT AN 'INDEX SEQUENCE'?        
         CB,T    *X                                                             
         BE       1Z2               YES, RESERVE A WORD FOR D                   
         LI,T     1                 NO, IS IT A SCALAR ?                        
         LB,R    *X,T                                                           
         BEZ      1Z4               YES                                         
         AWM,R    RSRANK            NO,ARRAY: BUMP RANK BY SCRIPT RANK          
         AI,X     1                                                             
         LI,S     1                                                             
1Z6      MW,S     *R,X                COMPUTE SCRIPT SIZE; RESERVE              
         BDR,R    1Z6                                                           
         AWM,S    VLENGTH             SPACE IN V FOR SCRIPT VALUES.             
         MTW,BN   BLENGTH           RESERVE SPACE FOR B-BLOCK                   
1Z4      BDR,NX   1Z1               SCAN NEXT SCRIPT                            
1Z5      LW,S     BLENGTH           COMPUTE TOTAL L-BLOCK SIZE:                 
         AW,S     VLENGTH               L = B+V                                 
         BAL,LX7  ALOCHNW           ALLOCATE L DATA BLOCK; A = PNTR             
         STW,A    LBLOCK            COPY L PNTR                                 
         STW,A    OLDLBLOK          SAVE FOR 'UPDATELP'                         
         LI,R     INTG**8           SET TYPE=INTG, RANK=0                       
         STH,R   *LBLOCK            (TYPE FIELD MUST BE LEGIT)                  
         AI,A     2                 BUMP PAST HEADER WORDS                      
         AW,A     BLENGTH           INIT B AND V PNTRS AT 1 + THE               
         STW,A    BPNTR               ENDS OF THEIR RESPECTIVE                  
         AW,A     VLENGTH             REGIONS.                                  
         STW,A    VPNTR                                                         
         LI,A     DBUFEND           INIT DIMEN PNTR                             
         STW,A    DIMENPTR                                                      
*                                                                               
*     SCAN SUBSCRIPTS, SET UP LOOP CONTROL DATA IN L-BLOCK              U10-0116
*                                                                               
         LW,X     SCRIPT            RE-CREATE SCRIPT LIST PNTR +2               
         AI,X     2                   (ALOCHNW MAY HAVE MOVED                   
         STW,X    SCRIPT2             THE SCRIPT LIST).                         
         LW,X     RTARG             CREATE POINTER TO RTARG DIMENS              
         AI,X     1                                                             
         STW,X    ARGDIMPT                                                      
         LW,X     BPNTR             CREATE POINTER TO INNERMOST                 
         AI,X     -BN                 B-BLOCK                                   
         STW,X    INERBLOK                                                      
         LI,X     1                                                             
         LB,NX   *RTARG,X           GET RIGHT ARG'S RANK                        
         CW,NX   *SCRIPT2           MAKE SURE IT AGREES WITH                    
         BNE      ERRANK              NUMBER OF SUBSCRIPTS.                     
         LI,R     0                 INITIALIZE:                                 
         STW,R    FVALUE              FIXED PART VALUE = 0                      
         LI,S     1                                                             
         STW,S    ISEQFLAG            ISEQ FLAG = .FALSE.                       
         STW,S    RSSIZE              RESULT SIZE = 1                           
         STW,S    WEIGHT              WEIGHT FACTOR = 1                         
2Z1      LW,X    *SCRIPT2,NX        GET NEXT SCRIPT PNTR                        
         BNEZ     2Z2               IS IT NULL ?                                
         LW,S    *ARGDIMPT,NX       YES, SIZE= CORRESPONDING DIMEN              
         LW,AI    WEIGHT            WEIGHTED STEP = 1*WEIGHT                    
         B        3Z2               CONTINUE LIKE ISEQ                          
2Z2      LB,T    *X                 GET TYPE CODE                               
         CI,T     ISEQ              HANDLE ISEQ SPECIALLY                       
         BE       3Z1                                                           
         LI,AI    1                                                             
         LB,R    *X,AI              GET RANK; IS IT SCALAR ?                    
         BEZ      2Z16              YES                                         
         STW,R    XRANK             REMEMBER RANK                               
         LI,S     1                 NO, INIT SIZE = 1                           
         AI,X     1                 POINT TO WORD BEFORE 1ST DIMEN              
2Z3      LW,AI   *R,X               COPY NEXT SCRIPT DIMEN                      
         MTW,-1   DIMENPTR            INTO DIMEN BUF,                           
         STW,AI  *DIMENPTR                                                      
         ODD,S                                                                  
         MW,S    *DIMENPTR            AND ACCUMULATE SIZE.                      
         BDR,R    2Z3               PROCESS ALL DIMENS                          
         AW,X     XRANK             POINT TO WORD BEFORE 1ST VALUE WORD         
         STW,S    XSIZE             SAVE SCRIPT SIZE                            
         AI,S     0                                                             
         BEZ      3Z5               IF SIZE=0; NO B-BLOCK, DO NEXT SCRPT        
         BAL,LZ   GARAYVAL,T        SIZE>0, GET ARRAY VALUES (INTG)             
         B        2Z11                (DONE)                                    
         BAL,LX   CHEKSUBS          OFFSET/CHECK SUBSCRIPT                      
         MW,AI    WEIGHT            APPLY WEIGHT FACTOR                         
         MTW,-1   VPNTR             STORE IT IN V-BLOCK                         
         STW,AI  *VPNTR                                                         
         B        *L1               GET NEXT VALUE                              
2Z11     LW,S     XSIZE             FINISH: GET SCRIPT SIZE                     
         STW,LZ   ISEQFLAG          RESET ISEQ FLAG (>0)                        
         LW,AI    VPNTR             GET V-POINTER                               
         SW,AI    LBLOCK            CONVERT TO L-BLOCK OFFSET VALUE             
         LI,L1    ARAYLOOP          SET LOOP TYPE = ARRAY                       
         B        3Z4               GO CREATE B-BLOCK ITEM                      
*                                                                               
2Z16     BAL,LZ   GSCLRVAL,T        GET SCALAR VALUE                            
         BAL,LX   CHEKSUBS          OFFSET/CHECK SUBSCRIPT VALUE                
         STW,LX   ISEQFLAG          RESET ISEQ FLAG (>0)                        
         ODD,AI                                                                 
         MW,AI    WEIGHT            INCR FIXED PART VALUE                       
         AWM,AI   FVALUE              BY WEIGHTED SCRIPT VALUE.                 
         B        3Z6               PROCESS NEXT SCRIPT                         
*                                                                               
3Z1      LW,AI    2,X               ISEQ: CHECK RANGE OF LAST VALUE:            
         BEZ      3Z7                                                           
         MW,AI    4,X                 = A+B*N                                   
         AW,AI    3,X                                                           
         BAL,LX   CHEKSUBS                                                      
         LW,AI    3,X               OFFSET/CHECK FIRST VALUE:                   
         AW,AI    4,X                 = A+B                                     
         BAL,LX   CHEKSUBS                                                      
         MW,AI    WEIGHT            INCR FIXED PART BY WEIGHTED                 
         AWM,AI   FVALUE              1ST SCRIPT VALUE.                         
3Z7      LW,S     2,X               SIZE = N                                    
         LW,AI    4,X               STEP = B * WEIGHT                           
         MW,AI    WEIGHT                                                        
3Z2      MTW,-1   DIMENPTR          ISEQ/NULL: PUT SIZE IN DIMEN BUF            
         STW,S   *DIMENPTR                                                      
         LI,L1    SEQLOOP           SET LOOP TYPE = SEQ                         
         LCW,R    ISEQFLAG          TEST ISEQ FLAG: WAS LAST SCRIPT             
         BLZ      3Z3                 AN ISEQ?                                  
         LW,T     BPNTR             YES, SEE IF WE CAN COMBINE THIS             
         LW,BI    BSTEPVAL,T          ONE WITH THE LAST; THIS IS                
         ODD,BI                                                                 
         MW,BI    BINITCNT,T          POSSIBLE IFF (LAST SIZE)*(LAST            
         CW,BI    AI                  STEP) = (THIS STEP).                      
         BNE      3Z4               RATS.                                       
         LW,AI    S                 OH GOOD; MODIFY LAST B-BLOCK BY             
         MW,AI    BINITCNT,T          SETTING ITS SIZE =                        
         STW,AI   BINITCNT,T          (LAST SIZE)*(THIS SIZE).                  
         B        3Z5                                                           
3Z3      STW,R    ISEQFLAG          ISEQ WAS RESET: SET IT NOW (<0)             
3Z4      MTW,-BN  BPNTR                                                         
         LW,T     BPNTR             BUILD NEW B-BLOCK:                          
         STW,AI   BSTEPVAL,T          INCLUDE ITS WEIGHTED STEP VALUE           
         STW,S    BINITCNT,T          (OR V-OFFSET) AND SIZE.                   
         STW,L1   BLOOPTYP,T          AND TYPE.                                 
3Z5      MW,S     RSSIZE            UPDATE RESULT SIZE                          
         STW,S    RSSIZE                                                        
3Z6      LW,AI   *ARGDIMPT,NX       UPDATE WEIGHT FACTOR                        
         MW,AI    WEIGHT                                                        
         STW,AI   WEIGHT                                                        
         BDR,NX   2Z1               DO NEXT SCRIPT                              
*                                                                               
*     DE-REF SCRIPT LIST DATA BLOCK                                     U10-0118
*                                                                               
DREFSCR  EQU      %                                                     U10-0120
         LI,A     0                                                             
         XW,A     SCRIPT            DISCARD SCRIPT LIST PNTR                    
         BAL,LX7  DREF              DE-REF SCRIPT LIST DATA BLOCK               
         B        *L2               RETURN                                      
         PAGE                                                                   
*                                                                               
*                                                                               
*  ALLOCATE LOOP CONTROL BLOCK                                                  
*                                                                               
*              CALLED WITH THE NUMBER OF B-BLOCKS NEEDED IN 'S'.                
*              ALLOCATES AN LBLOCK BIG ENOUGH FOR THAT MANY B-BLOCKS            
*              AND AN EMPTY V-BLOCK.  SETS UP LBLOCK, OLDLBLOK,                 
*              INERBLOK, OUTRBLOK, FVALUE. LINK IS L2.                          
*                                                                               
INDEXB   EQU      %                                                             
         MTW,-4   RETURN            ALTER RETURN ADR SO THAT, UPON              
*                                     EXIT FROM OP DRIVER, 'LBLOCK'             
*                                     WILL BE DE-REFFED                         
         MI,S     BN                COMPUTE TOTAL SIZE OF B-BLOCKS              
         STW,S    TEMP              SAVE IT                                     
         BAL,LX7  ALOCHNW           ALLOCATE L-BLOCK                            
         STW,A    LBLOCK            SAVE POINTER                                
         STW,A    OLDLBLOK            (FOR UPDATELP)                            
         LI,R     INTG**8           SET TYPE (MUSTN'T LEAVE IT 0)               
         STH,R   *LBLOCK                                                        
         AI,A     2                                                             
         STW,A    OUTRBLOK          PNTR TO OUTER B-BLOCK                       
         AW,A     TEMP                                                          
         AI,A     -BN                                                           
         STW,A    INERBLOK          PNTR TO INNER B-BLOCK                       
         LI,R     0                 INITIALIZE FIXED PART VALUE                 
         STW,R    FVALUE                                                        
         B       *L2                RETURN                                      
*                                                                               
TEMP     TEMP                                                                   
         PAGE                                                                   
*                                                                               
*                                                                               
*  SET UP PARAMETERS FOR THREE NESTED LOOPS                                     
*                                                                               
*              USES THE COORDINATE SPECIFICATION VALUE (OR RTRANK,              
*              IF NONE) TO SET UP THREE NESTED LOOPS: THE OUTER,                
*              CORRESPONDING TO COORDS 1,2,...,K-1; THE MIDDLE,                 
*              FOR COORD K; AND THE INNER FOR COORDS K+1,...,N                  
*              (WHERE K= COORD SPEC, N = RT RANK).  THIS ROUTINE                
*              SETS UP RANK/SIZE/TYPE CELLS IDENTICALLY FOR RT ARG              
*              AND RESULT, ALLOCATES RESULT DB, COPIES RT DIMENS                
*              TO RESULT, AND SETS UP LOOP CONTROL PARAMETERS AS                
*              FOLLOWS:                                                         
*                                                                               
*                   COORDK   = K                                                
*                   OUTRCNT  = D(1)*D(2)*...*D(K-1)                             
*                   OUTRSTEP = D(K)*D(K+1)*...*D(N)                             
*                   MIDLCNT  = D(K)                                             
*                   MIDLSTEP = D(K+1)*D(K+2)*...*D(N)                           
*                   INERCNT  = D(K+1)*D(K+2)*...*D(N)                           
*                  INERSTEP  = 1                                                
*                                                                               
*              IF THE RESULT SIZE IS 0 OR 1, THIS ROUTINE EXITS                 
*              TO 'MNOP' WHICH SETS RESULT = RTARG; OTHERWISE IT                
*              RETURNS TO CALLER. LINK IS L2.                                   
*                                                                               
*              'ST3LUPSK' IS AN ALTERNATE ENTRY WHICH USES THE VALUE            
*              IN REG 'K' AS COORDINATE SPEC, INSTEAD OF VALUE IN               
*              OPER WORDS.  'ST3LUPSN' IS AN ALTERNATE ENTRY WHICH              
*              DOESN'T ALOC RESULT, COPY DIMENS, OR EXIT TO 'MNOP'.             
*                                                                               
ST3LUPSN EQU      %                                                             
         AI,L2   -1**17             SET FLAG BIT                                
SET3LUPS EQU      %                                                             
         LB,T    *RTARG             GET ARG TYPE                                
         STW,T    RTTYPE                                                        
         LI,X     1                                                             
         LB,R    *RTARG,X           GET ARG RANK                                
         STW,R    RTRANK                                                        
         BEZ      10Z0              IF SCALAR, CHECK FOR NO COORD SPEC          
         LB,K     OPER+1            GET COORDINAT SPECIFICATION VALUE           
         BEZ      10Z1              IF ZERO, NONE WAS GIVEN                     
         CW,K     RTRANK            IF GIVEN, MAKE SURE COORD<=RANK             
         BLE      10Z2                                                          
         B        ERCOORD                                                       
10Z0     LB,K     OPER+1            RTARG IS SCALAR: NO COORDINATE              
         BNEZ     ERCOORD             MAY BE SPECIFIED.                         
         LI,S     1                                                             
         STW,S    INERSTEP            SET ALL LOOP PARAMS = 1                   
         STW,S    INERCNT                                                       
         STW,S    MIDLSTEP                                                      
         STW,S    MIDLCNT                                                       
         STW,S    OUTRSTEP                                                      
         B        10Z6                                                          
10Z1     LW,K     RTRANK            NO COORD: USE ARG RANK (=LAST COORD)        
*                                                                               
ST3LUPSK EQU      %                 SET LOOPS, USING K-REG VAL                  
10Z2     STW,K    COORDK            SET K'TH COORD                              
         MTW,1    RTARG             POINT TO 1ST DIMEN -1                       
         LW,X     RTRANK            PREPARE TO MULTIPLY ALL DIMENS              
         LI,S     1                 INIT INNER COUNT                            
         STW,S    INERSTEP          INNER STEP = 1                              
10Z3     CW,X     COORDK            WHEN THE K'TH COORD IS REACHED,             
         BNE      10Z4                                                          
         STW,S    INERCNT             SET INNER COUNT AND MIDDLE STEP           
         STW,S    MIDLSTEP            = D(K+1)*D(K+2)*...*D(N),                 
         MW,S    *RTARG,X             OUTER STEP                                
         STW,S    OUTRSTEP            = D(K)*D(K+1)*...*D(N),                   
         LW,S    *RTARG,X             AND MIDDLE COUNT = D(K);                  
         STW,S    MIDLCNT                                                       
         LI,S     1                   INIT S FOR OUTER COUNT,                   
         B        10Z5                SKIP DIMEN K.                             
10Z4     MW,S    *RTARG,X           ACCUM SIZE                                  
         BOV      ERLENGTH                                              10-00067
10Z5     BDR,X    10Z3                                                          
         MTW,-1   RTARG             DONE: RESTORE ARG PNTR                      
10Z6     STW,S    OUTRCNT           OUTER COUNT = D(1)*D(2)*...*D(K-1)          
         MW,S     OUTRSTEP                                                      
         BOV      ERLENGTH                                              10-00069
         STW,S    RTSIZE            SIZE = D(1)*D(2)*...*D(N)                   
         AI,L2    0                 IF SIGN BIT SET, ENTRY WAS                  
         BLZ     *L2                  'ST3LUPSN': DONT ALOC RS.                 
         BDR,S    10Z7              IF RESULT IS 1 ELEMENT,                     
         B        MNOP                RESULT = RTARG.                           
10Z7     BAL,L1   RSLIKERT          ALOC RESULT DB LIKE RT ARG                  
         BAL,LX   MRTDIMS           COPY ARG DIMENS TO RESULT                   
         B       *L2                RETURN                                      
*                                                                               
*                                                                               
INERCNT  TEMP                       INNER  LOOP COUNT                           
INERSTEP TEMP                       INNER  LOOP STEP                            
MIDLCNT  TEMP                       MIDDLE LOOP COUNT                           
MIDLSAVE TEMP                       MIDDLE LOOP STEP                            
MIDLSTEP TEMP                       MIDDLE LOOP SAVE CELL                       
OUTRCNT  TEMP                       OUTER  LOOP COUNT                           
OUTRSAVE TEMP                       OUTER  LOOP STEP                            
OUTRSTEP TEMP                       OUTER  LOOP SAVE CELL                       
COORDK   TEMP                       K'TH COORDINATE SPEC                        
*                                                                               
*                                                                               
*  EXCHANGE INNER/MIDDLE LOOPS                                                  
*                                                                               
*              EXHANGES INNER AND MIDDLE LOOP PARAMETRS, AND                    
*              SETS FVALUE TO ZERO.  LINK IS LX.                                
*                                                                               
EXCHLUPS EQU      %                                                             
         LW,R     INERCNT           SWAP COUNTS                                 
         XW,R     MIDLCNT                                                       
         STW,R    INERCNT                                                       
         LW,R     INERSTEP          SWAP STEPS                                  
         XW,R     MIDLSTEP                                                      
         STW,R    INERSTEP                                                      
         LI,R     0                 ZERO FVALUE                                 
         STW,R    FVALUE                                                        
         B        0,LX              RETURN                                      
         PAGE                                                                   
*                                                                               
*                                                                               
*  CHECK SUBSCRIPT                                                              
*                                                                               
*              THE SUBSCRIPT VALUE IN 'AI' IS OFFSET TO ORIGIN 0                
*              AND RANGE-CHECKED. OFFSET VALUE IS RETURNED IN 'AI'.             
*              LINK IS LX.                                                      
*                                                                               
CHEKSUBS SW,AI    ORIGIN            OFFSET TO ORIGIN 0                          
         BLZ      ERINDEX           MAKE SURE ITS VALUE IS                      
         CW,AI   *ARGDIMPT,NX         >=0 AND                                   
         BL       0,LX                < (CURRENT DIMEN).                        
         B        ERINDEX                                                       
         PAGE                                                                   
*                                                                               
*                                                                               
*   GET INTEGER ARRAY VALUES                                                    
*                                                                               
*              'GARAYVAL' IS USED TO FETCH, ONE BY ONE (FROM LAST               
*              TO FIRST), THE ELEMENTS OF AN ARRAY, CONVERTING THEM             
*              TO THE INTEGER DOMAIN.  IT IS CALLED WITH THE DATA               
*              BLOCK POINTER +RANK+1 IN X, SIZE (ELEMENTS) IN S,                
*              AND TYPE IN T; LINK IS LZ.  THE CALLING SEQUENCE                 
*              IS AS FOLLOWS:                                                   
*                                                                               
*                        BAL,LZ   GARAYVAL,T                                    
*                        B        ENDLOC                                        
*                        (PROCESS ONE VALUE)                                    
*                          ...                                                  
*                        B       *L1                                            
*                                                                               
*              'GARAYVAL' WILL RETURN TO BAL+2 ONCE FOR EACH ARRAY              
*              VALUE, WITH ITS INTG VAL IN AI AND LCC SET; VALUES ARE           
*              PASSED IN REVERSE RAVEL ORDER.  THE CALLER MUST NOT              
*              CLOBBER THE FOLLOWING REGS: S, T, X, LZ.                         
*              AFTER ALL VALUES HAVE BEEN PASSED, 'GARAYVAL' WILL               
*              RETURN TO BAL+1.                                                 
*                                                                               
GARAYVAL EQU      %-LOGL            GET ARRAY VALUE: JUMP TABLE                 
         B        7Z5               L VALUES: CONVERT TO I                      
         B        ERDOMAIN          C VALUES: WRONG                             
         B        7Z10              I VALUES: OK                                
         B        7Z8               F VALUES: CONVERT TO I                      
         B        7Z1               ISEQ: GEN VALUES                            
         B        ERDOMAIN          LIST: WRONG                                 
*                                                                               
7Z1      LW,AI    0,X               ISEQ: INIT TO LAST VAL                      
         MW,AI    2,X                                                           
         AW,AI    1,X                 = BASE+STEP*SIZE                          
7Z2      STW,AI   AVALTEMP          SAVE VALUE (USER CLOBBERS)                  
         BAL,L1   1,LZ              PASS IT TO CALLER                           
         LW,AI    AVALTEMP          RESTORE VALUE                               
         SW,AI    2,X               SUBTRACT STEP VAL                           
         BDR,S    7Z2               DO NEXT                                     
         B        0,LZ              END: RETURN TO ENDLOC                       
*                                                                               
7Z5      LCW,T    S                 SPLIT UP ARRAY  SIZE INTO                   
         AI,S     31                  WORD AND BIT COUNT.                       
         SLS,S    -5                S = WORD COUNT                              
         OR,T     =-32              T = - BIT COUNT                             
7Z6      LW,AI   *S,X               GET CURRENT WORD                            
         AND,AI   BITMASK+33,T      EXTRACT CURRENT BIT                         
         BEZ      7Z7               CONVERT TO INTG FORM:                       
         LI,AI    1                   0 OR 1.                                   
7Z7      BAL,L1   1,LZ              PROCESS ARRAY     VALUE                     
         BIR,T    7Z6               ALL BITS                                    
         LI,T     -32               RESET BIT COUNT                             
         BDR,S    7Z6               ALL WORDS                                   
         B        0,LZ              FINISH ARRAY        PROCESSING              
*                                                                               
7Z8      AND,X    =-2               FLOT: CONVERT PNTR TO DOUBLEWORD ADR        
         XW,S     X                 COUNT MUST BE IN INDEX                      
7Z9      LD,AF   *S,X               GET NEXT VALUE                              
         BAL,LX   F2I               CONVERT TO INTEGER                          
         B        ERDOMAIN            (IF POSSIBLE)                             
         BAL,L1   1,LZ              PROCESS IT                                  
         BDR,X    7Z9               ALL VALUES                                  
         B        0,LZ              FINISH                                      
*                                                                               
7Z10     LW,AI   *S,X               INTG: GET NEXT VALUE                        
         BAL,L1   1,LZ              PROCESS IT                                  
         BDR,S    7Z10              ALL VALUES                                  
         B        0,LZ              FINISH                                      
*                                                                               
AVALTEMP TEMP                       ARRAY VALUE TEMP                            
         PAGE                                                                   
*                                                                               
*                                                                               
*  GET INTEGER SCALAR VALUE                                                     
*                                                                               
*              'GSCLRVAL' IS USED TO OBTAIN THE VALUE OF A                      
*              SCALAR, CONVERTING IT TO THE INTEGER DOMAIN IF                   
*              NECESSARY.  IT IS CALLED WITH THE DATA BLOCK                     
*              POINTER IN X AND TYPE IN T; LINK IS LZ.                          
*              THE CALLING SEQUENCE IS:                                         
*                                                                               
*                        BAL,LZ   GSCLRVAL,T                                    
*                                                                               
*              THE VALUE IS RETURNED IN 'AI' WITH LCC SET ACCORDING             
*              TO VALUE'S SIGNUM.                                               
*                                                                               
GSCLRVAL EQU      %-LOGL            GET SCALAR VALUE: JUMP TABLE                
         B        8Z3               L VALUE: CONVERT TO I                       
         B        ERDOMAIN          C VALUE: WRONG                              
         B        8Z5               I VALUE: OK                                 
         B        8Z4               F VALUE: CONVERT TO I                       
         B        8Z1               ISEQ: (TO HANDLE 1-ELMT ARRAY)              
         B        ERDOMAIN          LIST: WRONG                                 
*                                                                               
8Z1      LW,AI    2,X               ISEQ: VALUE = BASE+STEP                     
         AW,AI    3,X                                                           
         B        0,LZ              RETURN                                      
*                                                                               
8Z3      LW,AI    2,X               LOGL SCALAR: GET VALUE                      
         AND,AI   =X'80000000'                                                  
         BEZ      0,LZ                                                          
         LI,AI    1                 CONVERT TO I-FORM                           
         B        0,LZ              RETURN                                      
*                                                                               
8Z4      AI,X     1                 FLOT SCALAR: GET VALUE                      
         SLS,X    -1                                                            
         LD,AF    2,X                                                           
         BAL,LX   F2I               CONVERT TO INTO                             
         B        ERDOMAIN            (IF POSSIBLE)                             
         B        0,LZ              RETURN                                      
*                                                                               
8Z5      LW,AI    2,X               INTG: GET VALUE                             
         B        0,LZ              RETURN                                      
         PAGE                                                                   
*                                                                               
*                                                                               
*  GET SUBSCRIPT VALUES                                                         
*                                                                               
*              THESE SUBROUTINES EXECUTE THE LOOPS  SPECIFIED BY THE            
*              L-BLOCK, DELIVERING ONE ZERO-ORIGIN SUBSCRIPT VALUE              
*              PER CALL.  '1STSCRPT' INITIALIZES THE LOOPS AND RETURNS          
*              THE FIRST SUBSCRIPT IN 'K'.  'NXTSCRPT' PRODUCES                 
*              ONE ADDITIONAL SUBSCRIPT IN 'K' EACH TIME IT IS CALLED.          
*              LINK IS L1.  THE FOLLOWING REGISTERS MUST                        
*              NOT BE CLOBBERED BY THE CALLER, ONCE THEY HAVE BEEN              
*              SET UP BY '1STSCRPT':    K, KB, KV, KN, KL.                      
*                                                                               
*                                                                               
*              THE LOOP CONTROL BLOCK CONTAINS THE PARAMETERS NEEDED            
*              TO INITIALIZE EACH LOOP, AND SPACE TO HOLD RUNNING               
*              LOOP VALUES.  FOR A NESTING DEPTH OF N, THE BLOCK                
*              CONSISTS OF N 6-WORD 'B-BLOCKS', EACH DESCRIBING ONE             
*              LOOP, AND A 'V-BLOCK' LARGE ENUF TO CONTAIN ALL THE SUB-         
*              SCRIPTS REQUIRED FOR 'ARRAY' LOOPS AS DESCRIBED BELOW.           
*              LET YJ(IJ) (FOR IJ=1,2,...,MJ) BE THE VALUES PRODUCED            
*              BY THE J'TH LOOP; THEN THE VALUES PRODUCED BY                    
*              1STSCRPT/NXTSCRPT ARE =FVALUE+Y1(I1)+Y2(I2)+...+YN(IN),          
*              WITH 'IN' RUNNING FASTEST AND 'I1' SLOWEST.                      
*                                                                               
*              EACH LOOP IS OF ONE OF THE FOLLOWING TYPES:                      
*                                                                               
*              1.  SEQUENCE LOOP: PRODUCES YJ(IJ)=(IJ-1)*STEPJ FOR              
*                  IJ =1,2,...,MJ. B-BLOCK CONTENTS:                            
*                                                                               
*                        WORD 0 = STEPJ                                         
*                        WORD 1 = MJ                                            
*                        WORD 2 = FVALUE+Y1(I1)+...+YJ(IJ)                      
*                        WORD 3 = MJ-IJ                                         
*                        WORD 4 = (UNUSED)                                      
*                        WORD 5 = 0 (OP CODE FOR 'SEQLOOP')                     
*                                                                               
*                  EACH ITERATION REDUCES WORD 3 BY 1, AND ADDS                 
*                  STEPJ TO WORD 2.                                             
*                                                                               
*              2.  ARRAY LOOP: PRODUCES YJ(IJ) = L(VJ+IJ-1) FOR                 
*                  IJ = 1,2,...,MJ.  B-BLOCK CONTENTS:                          
*                                                                               
*                        WORD 0 = VJ (OFFSET INTO V-BLOCK)                      
*                        WORD 1 = MJ                                            
*                        WORD 2 = LOC(L)+VJ+IJ-1                                
*                        WORD 3 = MJ-IJ                                         
*                        WORD 4 = FVALUE+Y1(I1)+...+YK(IK)   (K=J-1)            
*                        WORD 5 = -1 (OP CODE FOR 'ARAYLOOP')                   
*                                                                               
*                  EACH ITERATION REDUCES WORD 3 BY 1, INCREASES                
*                  WORD 2 BY 1 AND ACCESSES NEW YJ VALUE FROM V-BLOCK           
*                  LOCATION GIVEN BY WORD 2.                                    
*                                                                               
*              3.  MIXED SEQUENCE LOOP: USED BY 'TAKE' OPERATOR, THIS           
*                  LOOP PRODUCES PJ 'NULL GROUPS' FOLLOWED BY MJ-PJ             
*                  VALUES OF THE 'SEQUENCE' LOOP VARIETY - OR, IT               
*                  FIRST PRODUCES QJ VALUES, THEN MJ-QJ NULL GROUPS.            
*                    CASE 1: YJ(IJ) ='NULL GROUP' FOR IJ=1,...,PJ               
*                                   =(IJ-PJ-1)*STEPJ FOR IJ=PJ+1,...,MJ.        
*                    CASE 2: YJ(IJ) =(IJ-1)*STEPJ FOR IJ=1,...,QJ               
*                                   ='NULL GROUP' FOR IJ=QJ+1,...,MJ.           
*                  B-BLOCK CONTENTS:                                            
*                                                                               
*                        WORD 0 = STEPJ                                         
*                        WORD 1 = MJ                                            
*                        WORD 2 = FVALUE+Y1(I1)+...+YJ(IJ)                      
*                        WORD 3 = MJ-IJ                                         
*                        WORD 4 = T+IJ (T= NULL TEST VAL, SEE BELOW)            
*                        WORD 5 = (X,-2)  X (IN THE UPPER 8 BITS)               
*                                   IS THE INDEX INTO NULTSBUF FOR 'T'          
*                                   AND INTO NULCTBUF FOR 'G'. THE              
*                                   LOWER 24 BITS CONTAIN -2, THE OP            
*                                   CODE FOR 'MIXLOOP'.                         
*                                                                               
*                  NULTSBUF(X) CONTAINS 'T', THE NULL TEST VALUE: IN            
*                  CASE 1, T=-PJ<0; IN CASE 2, T=X'7FFFFFFF'-QJ>0.              
*                  NULCTBUF(X) CONTAINS 'G', THE NULL-GROUP COUNT:              
*                  G=MK*...*MN (K=J+1).                                         
*                  EACH ITERATION LOWERS WORD 3 BY 1 AND RAISES                 
*                  WORD 4 BY 1 TESTING ITS SIGN: IF T+IJ>0, THE LOOP            
*                  ACTS LIKE A 'SEQUENCE' LOOP, ADDING STEPJ TO                 
*                  WORD 2; IF T+IJ<=0, A NULL GROUP OF LENGTH G IS              
*                  PASSED TO THE RESULT, AND THE EXECUTION OF LOOPS             
*                  J+1,...,N IS SKIPPED.  NXTSCRPT PASSES THE NULL              
*                  GROUP BY PUTTING G IN REG 'N2' AND EXITING ON                
*                  LINK L2, INSTEAD OF L1.                                      
*                                                                               
*                                                                               
1STSCRPT EQU      %                 GET 1ST SCRIPT                              
         BAL,LX   UPDATELP          UPDATE L-BLOCK POINTERS                     
         LW,KB    OUTRBLOK          INIT B-BLOCK PNTR TO OUTERMOST BLOCK        
         LW,K     FVALUE            INIT SCRIPT VAL = FIXED PART VALUE          
         CW,KB    INERBLOK          ARE THERE ANY B-BLOCKS ?                    
         BLE      4Z6               YES, GO INITIALIZE THEM                     
         LI,KN    1                 NO, SET COUNT FOR 1 SCRIPT VAL              
         BAL,KL  *L1                  AND GIVE 'EM THE ONLY SCRIPT              
*                                     (FVALUE); SET KL TO SOMETHING             
*                                     SO 'BDR,KN 0,KL' WONT GET ADR             
*                                     TRAP (EVEN THOUGH IT WONT BRANCH).        
*                                                                               
NXTSCRPT EQU      %                 GET NEXT SCRIPT                             
         BDR,KN   *KL               BRANCH IF CURRENT LOOP NOT DONE             
*                                     (KL HAS BEEN SET BY ONE OF                
*                                     SEVERAL 'BAL,KL ...' OPS).                
4Z1      AI,KB    -BN               LOOP DONE: MOVE TO NEXT OUTER LOOP          
         CW,KB    OUTRBLOK          IF ALL LOOPS FINISHED,                      
         BL      *RETURN              EXIT FROM OP ROUTINE.             U10-0122
         LW,KN    BCOUNT,KB         RESTORE ITS SAVED COUNT                     
         LW,LX    BLOOPTYP,KB       GET LOOP TYPE CODE                          
         BDR,KN   4Z3,LX            GO TO APPROPRIATE RESTORE                   
         B        4Z1                                                           
4Z21     LW,KV    BOFFSET,KB        ARRAY LOOP: RESTORE OFFSET VAL              
*                                     LOC, THEN GO COUNT THIS LOOP.             
         AI,KV    1                 BUMP THE NON-INNER ARRAY LOOP:              
         LW,K    *KV                  INCR OFFSET, AND GET ARRAY ELMT;          
         AW,K     BADDEND,KB          ADD IN ADDEND.                            
4Z2      STW,KV   BOFFSET,KB        SAVE THIS LOOP'S OFFSET AND COUNT,          
         B        4Z5                 INIT INNER LOOPS.                         
*                                                                               
4Z3      TABLE    LOPBIAS           LOOP RESTORE ROUTINE TBL                    
         B        4Z13              MIXED SEQUENCE LOOP                         
         B        4Z21              ARRAY LOOP                                  
4Z31     LW,K     BSCRIPT,KB        SEQ LOOP: RESTORE SCRIPT VAL                
         AW,K     BSTEPVAL,KB       BUMP THE NON-INNER SEQUENCE LOOP            
4Z4      STW,K    BSCRIPT,KB          AND SAVE ITS SCRIPT VAL.                  
4Z5      STW,KN   BCOUNT,KB         SAVE THIS LOOP'S COUNT                      
         AI,KB    BN                INIT INNER LOOPS: MOVE TO NEXT              
4Z6      LW,KN    BINITCNT,KB         INNER LOOP; INITIALIZE COUNT              
         LW,LX    BLOOPTYP,KB       GET LOOP TYPE CODE                          
         B        4Z7,LX            GO TO APPROPRIATE INIT ROUTINE              
4Z61     LW,KV    BINITOFS,KB         AND OFFSET (IF ARRAY LOOP).               
         AW,KV    LBLOCK            ARRAY LOOP: CONVERT OFFSET TO               
         STW,K    BADDEND,KB          ACTUAL PNTR; SET ADDEND VAL.              
         AW,K    *KV                K = 1ST SCRIPT FOR THIS LOOP                
         CW,KB    INERBLOK          IF THIS ISN'T THE INNERMOST LOOP,           
         BL       4Z2                 SAVE ITS STUFF & INIT INNER LOOPS.        
         BAL,KL  *L1                SET KL TO INNER-ARRAY-LOOP LOC,             
*                                     AND RETURN K TO CALLER.                   
         AI,KV    1                 BUMP INNER ARRAY LOOP: INCR OFFSET,         
         LW,K    *KV                  FETCH NEXT ARRAY VALUE,                   
         AW,K     BADDEND,KB          AND ADD ADDEND.                           
         B       *L1                RETURN K TO CALLER.                         
*                                                                               
4Z7      TABLE    LOPBIAS           LOOP INIT ROUTINE TBL                       
         B        4Z9               MIXED SEQUENCE LOOP                         
         B        4Z61              ARRAY LOOP                                  
*                                   SEQ LOOP                                    
         CW,KB    INERBLOK          IF THIS ISN'T THE INNERMOST LOOP,           
         BL       4Z4                 SAVE ITS STUFF & INIT INNER LOOPS.        
         BAL,KL  *L1                SET KL TO INNER-SEQUENCE-LOOP LOC,          
*                                     AND RETURN K TO CALLER.                   
4Z8      AW,K     BSTEPVAL,KB       BUMP INNER SEQUENCE LOOP BY SIMPLY          
         B       *L1                  ADDING THE STEP VAL; RETURN.              
*                                   INIT MIXLOOP:                               
4Z9      LB,LX    LX                MIXLOOP: GET NULTSBUF INDEX                 
         LW,LX    NULTSBUF,LX       GET NULL TEST INITIALIZATION VALUE          
         STW,LX   BNULTEST,KB       INIT NULL TEST WORD                         
4Z10     MTW,1    BNULTEST,KB       BUMP NULL TEST VALUE                        
         BGZ      4Z11              >0  TREAT LIKE SEQLOOP                      
         LI,KL    4Z10              <=0 FIRST, SEND A NULL GROUP,               
         B        4Z12                THEN TRY AGAIN.                           
4Z11     CW,KB    INERBLOK          IS THIS THE INNERMOST LOOP ?                
         BL       4Z4               NO, SAVE STUFF & INIT NEXT INNER LUP        
         BAL,KL  *L1                YES, SEND SCRIPT (K) TO CALLER,             
         MTW,1    BNULTEST,KB         AND ADD STEP TO SCRIPT, AS LONG           
         BGZ      4Z8                 AS NULL TEST >0.                          
4Z12     LW,LX    BLOOPTYP,KB       GET NULCTBUF INDEX                          
         LB,LX    LX                                                            
         LW,N2    NULCTBUF,LX       GET NULL-GROUP COUNT                        
         B       *L2                GO TO SEND-NULL ROUTINE                     
4Z13     MTW,1    BNULTEST,KB       BUMP NON-INNER MIXLOOP                      
         BGZ      4Z31              IF NULL TEST >0, TREAT LIKE SEQLOOP         
         LI,KL    4Z13              IF <=0, SEND NULL GROUPS UNTIL              
         B        4Z12                IT GOES >0 (OR LOOP COUNTS OUT).          
         PAGE                                                                   
*                                                                               
*                                                                               
*  MOVE BUFFER DIMENSIONS                                                       
*                                                                               
*              COPIES DIMENSION BUFFER CONTENTS TO RESULT DIMENS.               
*              LINK IS LX.                                                      
*                                                                               
MBUFDIMS EQU      %                                                             
         LCW,X    RSRANK            GET -RANK                                   
         BEZ      0,LX              IF RANK=0, NO DIMENS TO MOVE                
         LW,A     RESULT            GET PNTR TO 1ST RS DIMEN -2                 
9Z1      LW,R     DBUFEND,X         GET DIMEN FROM BUFFER                       
         STW,R    2,A               STORE IT IN RESULT                          
         AI,A     1                                                             
         BIR,X    9Z1               DO 'EM ALL                                  
         B        0,LX              RETURN                                      
*                                                                               
*                                                                               
*  MOVE ARG DIMENSIONS                                                          
*                                                                               
*              COPIES RIGHT ARG DIMENSIONS TO RESULT DIMENS.                    
*              LINK IS LX.                                                      
*                                                                               
MRTDIMS  EQU      %                                                             
         LW,X     RSRANK            GET RANK                                    
         BEZ      0,LX              IF RANK=0, NO DIMENS TO MOVE                
         MTW,1    RTARG             POINT TO 1ST DIMEN -1                       
         MTW,1    RESULT                                                        
9Z2      LW,R    *RTARG,X           GET A DIMEN FROM ARG                        
         STW,R   *RESULT,X          STORE IT IN RESULT                          
         BDR,X    9Z2               DO 'EM ALL                                  
         MTW,-1   RTARG             RESTORE POINTERS TO NORMALCY                
         MTW,-1   RESULT                                                        
         B        0,LX              RETURN                                      
         PAGE                                                                   
*                                                                               
*                                                                               
*  SET UP ADDRESS FOR INDEXED LOAD/STORE                                        
*                                                                               
*              SETS UP LFADR  IF A=0; RTADR IF A=1; RSADR IF A=2.               
*              FOR CHAR/INTG/FLOT TYPE, SETS UP ADDRESS OF 1ST                  
*              DATA VALUE, WITH 'K' IN INDEX FIELD; FOR LOGL,                   
*              SETS UP ADR OF THE INDEXED LOAD-STORE LOGL ROUTINE.              
*              LINK IS LX. ADDRESS IS ALSO RETURNED IN 'R'.                     
*                                                                               
XSETUP   EQU      %                                                             
         LW,X     LFARG,A           GET ARG PNTR                                
         LI,T     1                                                             
         LB,R    *X,T               GET LEFT ARG RANK                           
         AW,R     LFARG,A                                                       
         AI,R     K**17+2           INIT ADR = ARG+RANK+2,K                     
         LB,T    *X                 GET TYPE CODE                               
         B        %+1-LOGL,T        GO INTO JUMP TABLE - BY TYPE:               
         B        6Z1               LOGL                                        
         B        6Z2               CHAR                                        
         B        6Z2               INTG                                        
         B        6Z3               FLOT                                        
         STW,R    XSEQLADR,A        ISEQ: SAVE BASE VALUE ADR                   
         LW,R     XSQADRTB,A        GET ADR OF ISEQ CALC ROUTINE                
         B        6Z2               STORE ADR, EXIT                             
*                                                                               
6Z1      STW,R    XLGLLADR,A        LOGL: SAVE ADR OF LOGL DATA                 
         LW,R     XLGADRTB,A        ADR = LOC OF LOGL COPY SUBR                 
6Z2      STW,R    LFADR,A           STORE ADR                                   
         B        0,LX              RETURN                                      
6Z3      AI,R     1                 FLOT: ADR =                                 
         AND,R    =-2                     ARG+RANK+(2 OR 3),K                   
         STW,R    LFADR,A           STORE ADR                                   
         B        0,LX              RETURN                                      
*                                                                               
XLGADRTB TABLE    0                 LOGL LOAD/STORE SUBR ADR TABLE              
         PZE      INDXLDLL          INDEXED LOAD LOGICAL LEFT                   
         PZE      INDXLDLR          INDEXED LOAD LOGICAL RIGHT                  
         PZE      INDXSTLG          INDEXED STORE LOGICAL RESULT                
*                                                                               
XSQADRTB TABLE    0                 ISEQ CALC ROUTINE ADR TABLE                 
         PZE      INDXLSQL          INDEXED LOAD ISEQ LEFT                      
         PZE      INDXLSQR          INDEXED ISEQ LOAD RIGHT                     
         PAGE                                                                   
*                                                                               
*                                                                               
*  SET UP ARG ADRS IN SPECIAL WAY                                               
*                                                                               
*              SETS LFADR FOR SEQUENTIAL LOAD  USING INDEX N1,                  
*              RTADR FOR INDICIAL LOAD USING INDEX K, AND RSADR                 
*              FOR SEQUENTIAL STORE USING INDEX N.  LINK  IS L1.                
*              ALSO SETS 'DELRSIZE' = (OLD RSSIZE)-(NEW RSSIZE).                
*              THIS VALUE IS NONZERO ONLY FOR CERTAIN CHARACTER RESULTS,        
*              IN WHICH CASE IT MAY EQUAL -1, -2, OR -3.                        
*                                                                               
SETN1KN  EQU      %                                                             
         LI,X     -3                SET UP LEFT ADR CELL FOR                    
         BAL,LX   SETADR              SEQUENTIAL LOAD.                          
SETSPEC1 EQU      %                                                             
         LI,A     1                 SET UP RTADR FOR                            
         BAL,LX   XSETUP              INDEXED LOAD: INDEX=K.                    
         LW,BI    RSSIZE            KEEP OLD RSSIZE                             
         LI,X     -1                SET UP RSADR FOR SEQUENCIAL                 
         BAL,LX   SETADR              STORE: INDEX(IF ANY) =N.                  
         SW,BI    RSSIZE            COMPUTE DELRSIZE = OLD RSSIZE               
         STW,BI   DELRSIZE            - NEW RSSIZE.                             
SETSPEC2 EQU      %                                                             
         LD,IX    N1REGMSK          IF IT HAS AN INDEX (=N, IF ANY),            
         CW,IX1   LFADR               CHANGE IT TO N1.                          
         BAZ      SETLK1                                                        
         STS,IX   LFADR                                                         
         B       *L1                RETURN                                      
SETLK1   LW,IX    LFADR             IF LFARG IS LOGL OR ISEQ,                   
         CI,IX    INDXLDLL            CHANGE ADR OF INDX-LOAD                   
         BE       20Z1                SUBROUTINE TO ADR OF ONE                  
         CI,IX    INDXLSQL            THAT USES K1 AS THE INDEX,                
         BNE     *L1                  INSTEAD OF K.                             
         LI,IX    INDSQLL1                                                      
         B        20Z2                                                          
20Z1     LI,IX    INDLDLL1                                                      
20Z2     STW,IX   LFADR                                                         
         B       *L1                                                            
*                                                                               
*                                                                               
         BOUND    8                                                             
N1REGMSK PZE      0,N1              N1 INDEX VALUE                              
         PZE      0,-1                AND MASK.                                 
*                                                                               
DELRSIZE TEMP                       CHANGE IN RSSIZE                            
         PAGE                                                                   
*                                                                               
*                                                                               
*  INDEXED LOAD LOGICAL                                                         
*                                                                               
*              LOADS INTO AI THE K'TH BIT (ORIGIN 0) OF                         
*              LFARG/RTARG.                                                     
*              LINK IS LX.  K IS NOT ALTERED.                                   
*                                                                               
INDXLDLL EQU      %                 INDEXED LOAD LOGICAL LEFT                   
         LW,AF    XLGLLADR          GET LFARG DATA ADR                          
         B        16Z1                                                          
INDXLDLR EQU      %                 INDEXED LOAD LOGICAL RIGHT                  
         LW,AF    XLGLRADR          GET RTARG DATA ADR                          
*                                   SPLIT SUBSCRIPT INTO                        
16Z1     LCW,AI   K                        -BIT INDEX IN AI                     
         OR,AI    =-X'20'                                                       
         SCS,K    -5                  AND WORD INDEX IN K.                      
         LW,AI    BITMASK+32,AI     SELECT APPROPRIATE BIT                      
         AND,AI  *AF,K                FROM APPROPRIATE WORD.                    
         SCS,K    5                 RESTORE K                                   
         BEZ      0,LX              CONVERT TO 0 OR -1 REPRESENTATION           
         LI,AI    -1                                                            
         B        0,LX                                                          
*                                                                               
*                                                                               
*  INDEXED LOAD LOGICAL, INDEX K1                                               
*                                                                               
*              LOADS INTO AI THE K1'TH BIT (ORIGIN 0) OF LFARG                  
*              LINK IS LX.  K1 IS NOT ALTERED.                                  
*                                                                               
INDLDLL1 EQU      %                 INDEXED LOAD LOGICAL LEFT (K1)              
*                                   SPLIT SUBSCRIPT INTO                        
         LCW,AI   K1                       -BIT INDEX IN AI                     
         OR,AI    =-X'20'                                                       
         SCS,K1   -5                  AND WORD INDEX IN K1.                     
         LW,AI    BITMASK+32,AI     SELECT APPROPRIATE BIT                      
         AND,AI   *XLGLLADR,K1        FROM APPROPRIATE WORD.                    
         SCS,K1   5                 RESTORE K1                                  
         BEZ      0,LX              CONVERT TO 0 OR -1 REPRESENTATION           
         LI,AI    -1                                                            
         B        0,LX                                                          
*                                                                               
*                                                                               
*  INDEXED STORE LOGICAL                                                        
*                                                                               
*              STORES AI (0 OR -1) INTO K'TH BIT (ORIGIN 0) OF RESULT.          
*              LINK IS LX. K IS NOT ALTERED.                                    
*                                                                               
INDXSTLG EQU      %                                                             
         LW,AI-1  AI                                                            
*                                   SPLIT SUBSCRIPT INTO                        
         LCW,AI   K                        -BIT INDEX IN AI                     
         OR,AI    =-X'20'                                                       
         SCS,K    -5                  AND WORD INDEX IN K.                      
         LW,AI    BITMASK+32,AI     SELECT APPROPRIATE BIT                      
         STS,AI-1 *XLGSTADR,K       STORE DATA BIT INTO APPROP WORD             
         SCS,K    5                 RESTORE INDEX VALUE                         
         LW,AI    AI-1              RESTORE VALUE OF AI                         
         B        0,LX                                                          
*                                                                               
XLGLLADR TEMP                       INDEXED LOGICAL LOAD LEFT ADR               
XLGLRADR TEMP                       INDEXED LOGICAL LOAD RIGHT ADR              
XLGSTADR TEMP                       INDEXED LOGICAL STORE ADR                   
*                                                                               
*                                                                               
*  INDEXED LOAD ISEQ                                                            
*                                                                               
*              COMPUTES K'TH ELEMENT OF ISEQ LFARG/RTARG                        
*              AND PLACES IT IN AI.  LINK IS LX.  K IS                          
*              NOT ALTERED.                                                     
*                                                                               
INDXLSQL EQU      %                 INDEXED LOAD ISEQ LEFT                      
         LW,AF    XSEQLADR          GET ISEQ BASE ADR                           
21Z1     LW,AI    K                 GET INDEX                                   
21Z2     ODD,AI                                                                 
         MW,AI    1,AF              ISEQ ELEMENT = STEP*(K+1)+BASE              
         AW,AI    1,AF                = STEP*K+STEP+BASE.                       
         AW,AI    0,AF                                                          
         B        0,LX              RETURN                                      
*                                                                               
INDXLSQR EQU      %                 INDEXED LOAD ISEQ RIGHT                     
         LW,AF    XSEQRADR          GAE RIGHT ISEQ BASE ADR                     
         B        21Z1              CONTINUE AS FOR LFARG                       
*                                                                               
INDSQLL1 EQU      %                 INDEXED LOAD ISEQ LEFT, K1 INDEX            
         LW,AF    XSEQLADR          GET BASE ADR                                
         LW,AI    K1                GET INDEX FROM K1, NOT K                    
         B        21Z2              CONTINUE AS FOR LF LOAD FROM K              
*                                                                               
XSEQLADR TEMP                       ISEQ BASE ADR FOR LFARG                     
XSEQRADR TEMP                       ISEQ BASE ADR FOR RTADR                     
         PAGE                                                                   
*                                                                               
*                                                                               
*  ALLOCATE RESULT LIKE RIGHT ARG                                               
*                                                                               
*              SETS UP RESULT RANK/SIZE/TYPE CELLS TO MATCH                     
*              THOSE OF RTARG, AND ALLOCATES THE RESULT DATA                    
*              BLOCK.  LINK IS L1.  PNTR RETURNED IN 'A' AND RESULT.            
*              'RSLIKRT1' IS AN ALTERNATE ENTRY WHICH DOES                      
*              THE SAME THING, EXCEPT IT TAKES RSTYPE FROM 'T'.                 
*              'RSLIKRT2' DOESN'T SET UP RSTYPE AT ALL.                         
*                                                                               
RSLIKERT EQU      %                                                             
         LW,T     RTTYPE                                                        
RSLIKRT1 EQU      %                                                             
         ISEQFIX,T                  USE TYPE INTG INSTEAD OF ISEQ               
         STW,T    RSTYPE            RESULT TYPE = ARG TYPE                      
RSLIKRT2 EQU      %                                                             
         LW,R     RTRANK                                                        
         STW,R    RSRANK            RESULT RANK = ARG RANK                      
         LW,S     RTSIZE                                                        
         STW,S    RSSIZE            RESULT SIZE = ARG SIZE                      
         B        ALOCRS            ALLOCATE RESULT; RETURN TO CALLER           
         PAGE                                                                   
*                                                                               
*  UPDATE L-BLOCK POINTERS                                                      
*                                                                               
*              IF THE L-BLOCK MAY HAVE BEEN MOVED (DUE TO AN ALLOCATION         
*              OR DE-REF OPERATION), A CALL UPON THIS ROUTINE WILL              
*              ASSURE THAT ALL NECESSARY L-BLOCK POINTERS REMAIN VALID.         
*              LINK IS LX.                                                      
*                                                                               
UPDATELP EQU      %                 UPDATE L-BLOCK POINTERS                     
         LW,K     LBLOCK            NEW L-BLOCK LOC                             
         SW,K     OLDLBLOK          OLD L-BLOCK LOC                             
         BEZ      0,LX              RETURN, IF THEY ARE EQUAL                   
         AWM,K    OLDLBLOK          NOT EQUAL: ADD DIFFERENCE TO                
         AWM,K    INERBLOK            ALL POINTERS.                             
         AWM,K    OUTRBLOK                                                      
         B        0,LX              RETURN                                      
*                                                                               
* LISTCHK-CHECKS LFARG AND RTARG-ERROR IF TYPE IS LIST OR HIGHER                
*                                                                               
LISTCHK  LI,A     LIST                                                          
         CB,A    *LFARG                                                         
         BLE      ERDOMAIN                                                      
         CB,A    *RTARG                                                         
         BG       0,LX                                                          
         B        ERDOMAIN                                                      
         PAGE                                                                   
*                                                                               
*                                                                               
*  TEMPS FOR INDEX ROUTINES                                                     
*                                                                               
ARGDIMPT TEMP                       ARG DIMEN POINTER                           
BLENGTH  TEMP                       B BLOCK LENGTH                              
VLENGTH  TEMP                       V BLOCK LENGTH                              
BPNTR    EQU      OUTRBLOK          B BLOCK POINTER                             
VPNTR    TEMP                       V BLOCK POINTER                             
DIMENPTR TEMP                       DIMENSION POINTER                           
SCRIPT2  TEMP                       SUBSCRIPT LIST PNTR +2                      
ISEQFLAG TEMP                       ISEQ FLAG (<0 FOR .TRUE.)                   
XRANK    TEMP                       SUBSCRIPT RANK                              
XSIZE    TEMP                       SUBSCRIPT SIZE                              
WEIGHT   TEMP                       WEIGHT FACTOR                               
FVALUE   TEMP                       FIXED PART VALUE                            
OLDLBLOK TEMP                       OLD L-BLOCK POINTER                         
INERBLOK TEMP                       INNERMOST B-BLOCK POINTER                   
OUTRBLOK TEMP                       OUTERMOST B-BLOCK POINTER                   
*                                                                               
                  ERROR,X'F',TLOC>38  'TOO MANY TEMPS'                  U10-0124
NTEMPS   SET      TLOC                                                  U10-0125
23Z      END                                                                    
