%RECORDFORMAT JSVFORMAT( %LONGINTEGER IVALUE, %C
%INTEGER SIZE,KPOS,MAXREC, %C
%STRING(32) LNAME, %STRING(48) NAME, %C
%BYTEINTEGER FORMAT,ORG,KLEN,ACCESS,PACKING,DUM1)
%OWNRECORDARRAYFORMAT JSVAF(0:20)(JSVFORMAT)
%OWNRECORDARRAYNAME JSV(JSVFORMAT)
%OWNLONGINTEGERNAME JSN
%OWNINTEGER JSMAX=20
%OWNINTEGER QUITLNB,QUITCTB,QUITXNB,CREG34,CREG36
%RECORDFORMAT RF(%INTEGER CONAD,FILETYPE,DATASTART,DATAEND)
!
!    GLOBAL DECLARATIONS
!
%OWNSTRING(16) LIBFILNAME="COBLIB"
%OWNSTRING(16) COBRUNFN="COBRUNY"
%CONSTINTEGER FCMAX=10; !  MAXIMUM NUMBER OF FILE CONTROL BLOCKS
%CONSTINTEGER EBCDICSPACE=64
%OWNINTEGER FCN

!
!    FILE CONTROL BLOCKS ETC.
!
%RECORDFORMAT FCBFORMAT(%LONGINTEGER CAPABILITY,KEYBUFFER,ACCESS1, %C
      ACCESS2,LISP1, %C
         %INTEGER CONNECTADDRESS,STARTOFDATA,ENDOFDATA,PTR, %C
    RECORDCOUNT,ENDOFFILE,MAXREC,KEYPOSN,KEYLENGTH,RECORDVIEW, %C
      MAXSIZE,BUFFERLENGTH,BUFFERADDRESS,CURRENTLENGTH,RECSIZEADD, %C
      RECORDBUFF0,RECORDBUFF1, %C
    ACTION,DISPLACEMENT,POSITION,NUMBUFF,SETACTION,JSVPTR,ISP3,ISP4, %C
      %INTEGER OPEN,BSINDEX, %C
       FILETYPE,BISP1,BISP2)
%OWNRECORDARRAY FCB(1:10)(FCBFORMAT)
!
!**********************************************************************
!*
!*                            CONSTANTS
!*
!**********************************************************************
!
%CONSTINTEGER NO = 0,         %C
              YES = 1
%CONSTINTEGER NIL = -1
%CONSTINTEGER DUMMYSTREAM=10
%CONSTSTRING(1)%ARRAY HEX TAB(0:15)="0","1","2","3","4","5","6","7", %C
              "8","9","A","B","C","D","E","F"
!
!
!
!**********************************************************************
!*
!*                            GLOBALS
!*
!**********************************************************************
!
!?2; %OWNINTEGER TRACE COUNT
!?2; %OWNINTEGER TRACE STREAM
%OWNINTEGER LOG STREAM
%OWNSTRING(6) USER NAME
!********************************************************************
!
!                          LOCAL ROUTINE SPECS
!
!*******************************************************************************
%ROUTINESPEC PP(%INTEGER INDEX,PDR0,PDR1)
%INTEGERFNSPEC ACCESS1(%INTEGER INDEX,PDR0,PDR1)
%INTEGERFNSPEC ACCESS2(%INTEGER INDEX)
%INTEGERFNSPEC PERFORMIO(%INTEGER INDEX)
%INTEGERFNSPEC DESELECTRAM(%INTEGER INDEX)
!************************************************************************
!
!                  EXTERNAL ROUTINE SPECS
!
!
!***************************************************************************
%EXTERNALROUTINESPEC PARM(%STRING(255) S)
%EXTERNALROUTINESPEC RUN(%STRING(255) S)
%EXTERNALROUTINESPEC NEWSMFILE(%STRING(255) S)
%EXTERNALINTEGERFNSPEC SMADDR(%INTEGER AD, %INTEGERNAME L)
%EXTERNALROUTINESPEC CLOSESM(%INTEGER CHAN)
%SYSTEMROUTINESPEC CHANGEFILESIZE(%STRING(31) FILE, %C
%INTEGER NEWSIZE, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC DISCONNECT(%STRING(31) FILE, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC REROUTECONTINGENCY(%INTEGER EP,CLASS, %C
%LONGINTEGER MASK, %ROUTINENAME RR, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC FINDENTRY(%STRING(31)NAME, %INTEGER TYPE,DAD, %C
      %STRINGNAME FILE, %INTEGERNAME DR0,DR1,FLAG)
%EXTERNALINTEGERFNSPEC RETURNCODE
%EXTERNALINTEGERFNSPEC OUT STREAM
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I)
%EXTERNALROUTINESPEC DEFINE(%STRING(255) PARMS)
%EXTERNALROUTINESPEC PROMPT(%STRING(15) NEWPROMPT)
%SYSTEMROUTINESPEC DESTROY(%STRING(255) S)
%SYSTEMROUTINESPEC CONNECT(%STRING(31) FILE %INTEGER MODE, %C
      HOLE,PROTECT %RECORDNAME R %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC OUTFILE(%STRING(31) FILE NAME,       %C
      %INTEGER SIZE,GAP,PROTECTION, %C
      %INTEGERNAME CONNECTED ADDR,FLAG)
%SYSTEMSTRINGFNSPEC NEXT TEMP
%SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH,FROM,TO)
%SYSTEMROUTINESPEC ITOE(%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC ETOI(%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC FILL(%INTEGER LENGTH,ADDRESS,FILLER)
%SYSTEMROUTINESPEC PRINTMESS(%INTEGER MESS)
%EXTERNALSTRINGFNSPEC UINFS(%INTEGER ENTRY)
!
!**********************************************************************
!*
!*                        SERVICE  ROUTINES
!*
!**********************************************************************
!
!
%EXTERNALROUTINE PARMSCAN(%STRINGNAME S %INTEGER NPARM %C
%STRINGARRAYNAME KEYS,LITS %INTEGERARRAYNAME MODE,PV %C
%INTEGERNAME LCNT %INTEGER INITVALUE)
!
!S       STRING CONTAINING PARAMETER SEQUENCE AS INPUT
! NPARM     NMAX NO OF PARAMETERS POSSIBLE
! KEYS      LIST OF KEYWORDS
! MODE      MODE OF PARAMETERS (0=INTEGER, 1=LITERAL,2=SUPERLITERAL)
! PV        POINTER OR VALUE (IF MODE=0 - VALUE, ELSE POINTER TO
!                      INDEX IN LITS
! LITS      ARRAY OF LITERALS, LISTS OF COMPONENTS OF
!             SUPERLITERALS ARE TERMINATED WITH ".END"
! ALL VALUES OF PVARE INITIALLY SET TO INITVALUE SO THAT THE
! CALLING ROUTINE CAN IDENTIFY WHICH PARAMETRS HAVE BEEN SET.
!
%EXTERNALINTEGERFNSPEC PSTOI(%STRING(63) S)
%ROUTINESPEC GETPARM(%STRINGNAME S,P)
%ROUTINESPEC SETPARM(%STRINGNAME Q %INTEGER K)
!
%STRING(255) STEMP,A,B,P
%STRING(3) SNAME
%INTEGER I,J,FOUND,POSITION
!
!
STEMP=S ; LCNT=1 ;POSITION=1
%UNTIL STEMP = "" %THEN %CYCLE
GETPARM(STEMP,P)
      %IF P->A.("=").B %THEN %START
    P=B
         FOUND=0
         %CYCLE J=1,1,NPARM
         SNAME<-KEYS(J) ;! SET 3-CHARACTER ABBREVIATION
         %IF A=KEYS(J) %OR A=SNAME %THEN FOUND=J %AND %EXIT
       %REPEAT
      %IF FOUND=0 %THEN %START
            NEWLINE;PRINTSTRING("KEYWORD ".SNAME." NOT VALID")
            %FINISH %C
      %ELSE POSITION=FOUND
      %FINISH
SETPARM(P,POSITION)
POSITION=POSITION + 1
%IF  POSITION > NPARM %THEN POSITION = POSITION - NPARM
%REPEAT
%RETURN
!
!      GETPARM  EXTRACTS NEXT PARM STRING FROM INPUT STRING S
!
%ROUTINE GETPARM(%STRINGNAME S,P)
%IF S->P.(",").S %THEN %RETURN
P=S ; S=""
%END
!
!  SETPARM  SETS VALUES INTO ARRAYS PV AND LITS
!       ACCORDING TO MODE OF PARAMETER
!
%ROUTINE SETPARM(%STRINGNAME Q %INTEGER K)
%SWITCH SW(0:2)
%STRING(255) QS
-> SW(MODE(K))
!
! INTEGER
!
SW(0):PV(K)=PSTOI(Q); %RETURN
!
! LITERAL
!
SW(1):PV(K)=LCNT;LITS(LCNT)=Q;LCNT=LCNT+1;%RETURN
!
! SUPERLITERAL
!
SW(2):PV(K)=LCNT
%WHILE Q->QS.("&").Q %THEN LITS(LCNT)=QS %AND LCNT=LCNT+1
LITS(LCNT)=Q;LITS(LCNT+1)=".END";LCNT=LCNT+2;%RETURN
%END
%END
%INTEGERFN CONNECTJSFILE(%STRING(31) FILENAME)
%RECORD R(RF)
%INTEGER FLAG,START,LEN
FLAG=0;CONNECT(FILENAME,3,2047,0,R,FLAG)
%IF FLAG#0 %THEN %START
      %IF FLAG=218 %THEN OUTFILE(FILENAME,2047,2047,0,R_CONAD,FLAG) %C
       %AND INTEGER(R_CONAD+32)=0 %C
         %ELSE %RESULT=-1
%IF FLAG#0 %THEN %RESULT=-2
      %FINISH
%RESULT=R_CONAD+32
%END
%SYSTEMSTRING(15)%FN SFROMI (%INTEGER X)
%INTEGER REM,NUMB,NF
%STRING(15) ANS
ANS = ''
%IF X < 0 %THEN %START
    NF = YES
    X = X*(-1)
%FINISH %ELSE NF = NO
%CYCLE
NUMB = X
X = X//10
REM = NUMB - X*10
ANS = TOSTRING(REM+'0').ANS
%EXIT %IF X = 0
%REPEAT
%IF NF = YES %THEN ANS = "-".ANS
%RESULT = ANS
%END     ;!  OF SFROMI
!
%INTEGERFN IFROMS (%STRING(20) NUMBER)
%INTEGER I,J,K,L
K=ADDR(NUMBER)
J=0
%CYCLE I=1,1,20
    L = BYTEINTEGER(K+I)
    %IF L<'0' %OR L>'9' %THEN %RESULT = J
    J=(J*10)+L-'0'
%REPEAT
%END     ;!  OF IFROMS
!
%ROUTINE LOG (%STRING(120) MSG)
%INTEGER CURRENT STREAM
CURRENT STREAM = OUTSTREAM
SELECT OUTPUT (LOG STREAM)
SPACES(9)
PRINTSTRING(MSG) ; NEWLINE
SELECT OUTPUT(CURRENT STREAM)
%RETURN
%END     ;!  OF LOG
%ROUTINE TLOG (%STRING(120) MSG)
%INTEGER CURRENT STREAM
CURRENT STREAM = OUTSTREAM
SELECT OUTPUT (TRACE STREAM)
SPACES(9)
PRINTSTRING(MSG) ; NEWLINE
SELECT OUTPUT(CURRENT STREAM)
%RETURN
%END     ;!  OF TLOG
!
!?1; %STRING(8)%FN HEXOF (%INTEGER X)
!?1; %STRING(8) ANS
!?1; %INTEGER I
!?1; ANS = ''
!?1; %CYCLE I=0,4,28
!?1;     ANS = HEXTAB((X>>I)&X'0000000F').ANS
!?1; %REPEAT
!?1; %RESULT = ANS
!?1; %END     ;!  OF HEXOF
%STRING(255)%FN STRING FROM(%INTEGER L,ADDRESS)
%STRING(255) S
*LB   _L
*LDA  _ADDRESS
*LDTB _X'18000000'
*LDB  _%B
*CYD  _0
*LD   _S
*MVL  _%L=1
*MV   _%L=%DR,0,129
ETOI(ADDR(S)+1,LENGTH(S))
%RESULT = S
%END       ;!  OF STRING FROM
!
!
%STRING(160)%FN NEXT LINE
%INTEGER I
%BYTEINTEGERARRAY LINE (0:160)
%WHILE NEXT SYMBOL = NL %THEN SKIP SYMBOL
%CYCLE I=1,1,160
    READ SYMBOL(LINE(I))
    %IF LINE(I) = NL %THEN %EXIT
%REPEAT
LINE(0) = I-1
%RESULT = STRING(ADDR(LINE(0)))
%END     ;!  OF NEXT LINE
!
%STRING(255)%FN DE SPACED (%STRING(255) S)
%STRING(255) B,A
%WHILE S -> B.(" ").A %THEN S = B.A
%RESULT = S
%END    ;!  OF DE SPACED
!
!
!?; %ROUTINE POSTREPORT(%STRING(40) RTN,%INTEGER RC)
!?; TLOG("RETURNED FROM ".RTN." RESULT= ".SFROMI(RC))
!?; %END;         ! OF POST REPORT
!
!?; %ROUTINE EXITREP(%STRING(40) RTN,%INTEGER RC)
!?; TLOG("ABOUT TO RETURN FROM ".RTN." RESULT = ".SFROMI(RC))
!?; %END;          ! OF EXITREP
!?1; %ROUTINE ASK FOR STREAM(%INTEGERNAME STREAM,%STRING(15) P)
!?1; %INTEGER X,RC
!?1; %STRING(80) REPLY
!?1; !
!?1; RC = 1
!?1; PROMPT(P)
!?1; %WHILE RC > 0 %THEN %CYCLE
!?1;     REPLY = DESPACED(NEXT LINE)
!?1;     %IF REPLY = "" %THEN %RETURN
!?1;     X = IFROMS(REPLY)
!?1;     %IF X>0 %AND X<80 %THEN STREAM = X %AND %RETURN
!?1;     DEFINE(SFROMI(STREAM).",".REPLY)
!?1;     X = RETURN CODE
!?1;     %IF X = 0 %THEN %RETURN
!?1;     PRINTSTRING("REPLY NOT VALID")
!?1;     NEWLINE
!?1; %REPEAT
!?1; %RETURN
!?1; %END      ;!  OF ASK FOR STREAM
!
%ROUTINE XDUMP (%STRING(120) COMMENT,%INTEGER ADDRESS,LEN)
%STRING(132) BUFFER
%INTEGER I,J,XSTART,XFINISH,YSTART,YFINISH
XSTART = (ADDRESS//32)*32
XFINISH = ((ADDRESS+LEN)//32)*32
YSTART = (ADDRESS//4)*4 - 4
YFINISH = ((ADDRESS+LEN)//4)*4 + 4
PRINTSTRING (COMMENT)
NEWLINE
PRINT STRING ('DUMP OF '.SFROMI(LEN).'(X'.HEXOF(LEN).      %C
             ') BYTES STARTING FROM ADDRESS '.HEXOF(ADDRESS))
%CYCLE I=XSTART,32,XFINISH
    BUFFER = HEXOF(I).'    '
    %CYCLE J=I,4,I+28
        %IF J > YSTART %AND J < YFINISH %THEN        %C
             BUFFER = BUFFER.HEXOF(INTEGER(J)).'  '  %ELSE    %C
             BUFFER = BUFFER.'........  '
    %REPEAT
    NEWLINE
    PRINTSTRING (BUFFER)
%REPEAT
NEWLINE
PRINTSTRING ('END OF DUMP')
%RETURN
%END      ;!  OF DUMP
!?2; %ROUTINE TRACE (%STRING(40) RTN,MSG,%INTEGER LNB,N)
!?2; %STRING (255) WORKA,WORKB
!?2; %INTEGER CURRENT STREAM
!?2; TRACE COUNT = TRACE COUNT + 1
!?2; WORKA="TRACE CALL >>".SFROMI(TRACE COUNT)."<<  ".RTN."  ".MSG
!?2; CURRENT STREAM = OUT STREAM
!?2; SELECT OUTPUT (TRACE STREAM)
!?2; NEWLINES(2)
!?2; PRINTSTRING(WORKA)
!?2; NEWLINE
!?2; WORKB="STACK DUMP STARTING FROM LNB, ".SFROMI(N)." WORDS OF PARMS"
!?2; !XDUMP(WORKB,LNB,(10+N)*4)
!?2; NEWLINE
!?2; SELECT OUTPUT(CURRENT STREAM)
!?2; %RETURN
!?2; %END       ;!  OF TRACE
!
!    ROUTINE TO RETURN DESCRIPTOR TO ANOTHER ROUTINE
!
%LONGINTEGERFN RTNDESC(%INTEGERFN R)
%LONGINTEGER LI
*LSD_(%LNB+5)
*ST_LI
%RESULT=LI
%END
%ROUTINE DUMPTCB(%INTEGER INDEX)
%RECORDNAME TCB(FCBFORMAT)
%INTEGER I,J,CURRENTSTREAM
TCB==FCB(INDEX)
!
CURRENTSTREAM=OUTSTREAM
SELECTOUTPUT(TRACESTREAM)
NEWLINE;PRINTSTRING("TCB DUMP INDEX=");WRITE(INDEX,5)
NEWLINE
PRINTSTRING("PTR=");PRINTSTRING(HEXOF(TCB_PTR))
NEWLINE;PRINTSTRING("CONAD=");PRINTSTRING(HEXOF(TCB_CONNECTADDRESS))
NEWLINE;PRINTSTRING("START,ENDDATA AND ENDFILE=")
PRINTSTRING(HEXOF(TCB_STARTOFDATA))
SPACES(5);PRINTSTRING(HEXOF(TCB_ENDOFDATA))
SPACES(5);PRINTSTRING(HEXOF(TCB_ENDOFFILE))
NEWLINE
SELECTOUTPUT(CURRENTSTREAM)
%RETURN
%END
!*********************************************************************
!
!           ROUTINE PP    USED BY CTMSELECTRAM AND ACCESS1 ROUTINES
!
!*****************************************************************************
%EXTERNALROUTINE PP(%INTEGER INDEX,PDR0,PDR1)
!
!   PROCESSES PARAMETER CALLS UPDATING FIELDS IN FCB(INDEX)
!
%RECORDNAME TCB(FCBFORMAT)
%INTEGER N,A,I,K,ALIGNMENT,CURRENTSTREAM
%SWITCH SW(0:30)
!
TCB==FCB(INDEX)
!
N=(PDR0&X'00FFFFFF')//3
CURRENTSTREAM=OUTSTREAM
!?;SELECTOUTPUT(TRACESTREAM);PRINTSTRING("PP-DUMP");NEWLINE
%CYCLE I=1,1,N
A=PDR1 + 12*(I-1)
K=INTEGER(A)
!?;WRITE(K,5);SPACES(3);PRINTSTRING(HEXOF(INTEGER(A+4)));SPACES(3)
!?;PRINTSTRING(HEXOF(INTEGER(A+8)));NEWLINE
->SW(K)
!
!  CAPABILITIES  ACCESS1 AND ACCESS2
!
SW(16):MOVE(8,A+4,ADDR(TCB_CAPABILITY)) ; ->ENDLOOP
SW(24):MOVE(8,ADDR(TCB_ACCESS1),INTEGER(A+8));->ENDLOOP
SW(19):MOVE(8,ADDR(TCB_ACCESS2),INTEGER(A+8)) ; ->ENDLOOP
!
!   ALIGNMENT    2=START OF FILE   3=END OF FILE
!
SW(29):ALIGNMENT=INTEGER(A+4)
      %IF ALIGNMENT=2 %THEN TCB_PTR=-1
      %IF ALIGNMENT=3 %THEN TCB_PTR=TCB_ENDOFDATA
      ->ENDLOOP
!
!   KEY BUFFER
!

SW(3):MOVE(8,A+4,ADDR(TCB_KEYBUFFER)) ; ->ENDLOOP
!
!  ACTION DISPLACEMENT AND POSITION
!
SW(0): TCB_ACTION=INTEGER(A+4) ; ->ENDLOOP
SW(4): TCB_POSITION=INTEGER(A+4) ; ->ENDLOOP
SW(5): TCB_DISPLACEMENT=INTEGER(A+4) ; ->ENDLOOP
!
!   RECORD AND BUFFER SIZE
!
SW(7):TCB_BUFFERLENGTH=INTEGER(A+4)&X'00FFFFFF'
      TCB_BUFFERADDRESS=INTEGER(A+8);->ENDLOOP
SW(9):TCB_RECSIZEADD=INTEGER(A+8); ->ENDLOOP
!
!   NUMBER OF IO BUFFERS
!
SW(22) : TCB_NUMBUFF=INTEGER(A+4) ; ->ENDLOOP
!
!   SETACTION
!
SW(12):TCB_SETACTION=INTEGER(A+4);->ENDLOOP
!
ENDLOOP:%REPEAT
SELECTOUTPUT(CURRENTSTREAM)
%RETURN
%END
!***************************************************************
!
!                  ACCESS1X AND ACCESS2X ROUTINES
!
!***************************************************************************
!
%INTEGERFN ACCESS11(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(1,PDR0,PDR1)
%END
%INTEGERFN ACCESS12(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(2,PDR0,PDR1)
%END
%INTEGERFN ACCESS13(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(3,PDR0,PDR1)
%END
%INTEGERFN ACCESS14(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(4,PDR0,PDR1)
%END
%INTEGERFN ACCESS15(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(5,PDR0,PDR1)
%END
%INTEGERFN ACCESS16(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(6,PDR0,PDR1)
%END
%INTEGERFN ACCESS17(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(7,PDR0,PDR1)
%END
%INTEGERFN ACCESS18(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(8,PDR0,PDR1)
%END
%INTEGERFN ACCESS19(%INTEGER PDR0,PDR1)
%RESULT=ACCESS1(9,PDR0,PDR1)
%END
%INTEGERFN ACCESS21
%RESULT=ACCESS2(1)
%END
%INTEGERFN ACCESS22
%RESULT=ACCESS2(2)
%END
%INTEGERFN ACCESS23
%RESULT=ACCESS2(3)
%END
%INTEGERFN ACCESS24
%RESULT=ACCESS2(4)
%END
%INTEGERFN ACCESS25
%RESULT=ACCESS2(5)
%END
%INTEGERFN ACCESS26
%RESULT=ACCESS2(6)
%END
%INTEGERFN ACCESS27
%RESULT=ACCESS2(7)
%END
%INTEGERFN ACCESS28
%RESULT=ACCESS2(8)
%END
%INTEGERFN ACCESS29
%RESULT=ACCESS2(9)
%END
!************************************************************************
!
!                        ACCESS1
!
!*****************************************************************************
!
%INTEGERFN ACCESS1(%INTEGER INDEX,PDR0,PDR1)
%RECORDNAME TCB(FCBFORMAT)
%INTEGER N,A,X,RC
%STRING(32) S
!?;S=SFROMI(INDEX)
!?;*STLN_X
!?;TRACE("ACCESS1",S,X,3)
TCB==FCB(INDEX)
%IF PDR0=-1 %THEN ->PIO
!
!
!   PROCESS PARAMETER PAIRS AND CALL PERFORMIO
!
TCB_SETACTION=-1
N=PDR0&X'00FFFFFF'
A=PDR1
PP(INDEX,N,A)
PIO:RC=PERFORMIO(INDEX)
%IF TCB_SETACTION#-1 %THEN TCB_ACTION=TCB_SETACTION
!?;EXITREP("ACCESS1",RC)
%RESULT=RC
%END
!****************************************************************************
!
!                             ACCESS2
!
!***********************************************************************
%INTEGERFN ACCESS2(%INTEGER INDEX)
%INTEGER X,RC
%STRING(5) S
!?S=SFROMI(INDEX)
!?*STLN_X
!?TRACE("ACCESS2",S,X,1)
RC=PERFORMIO(INDEX)
!?EXITREP("ACCESS2",RC)
%RESULT=RC
%END
!*****************************************************************************
!
!                          PERFORMIO
!
!*****************************************************************************
!
%INTEGERFN PERFORMIO(%INTEGER INDEX)
%INTEGER X,RC,ACTION,POSITION,DISP,RECLENGTH,LENGTH
%RECORDNAME TCB(FCBFORMAT)
%SWITCH ACT(0:16),ACT0POS(0:4),ACT1POS(0:4),ACT2POS(0:4)
!
!    ESTABLISH ADDRESS OF FCB IN TCB
!
TCB==FCB(INDEX)
!?;DUMPTCB(INDEX)
!
ACTION=TCB_ACTION 
%IF ACTION=-1 %THEN RC=0 %AND ->RETURN
 POSITION=TCB_POSITION ; DISP=TCB_DISPLACEMENT
!
->ACT(ACTION)
!
ACT(0):->ACT0POS(POSITION)
ACT(1):->ACT1POS(POSITION)
ACT(2):->ACT2POS(POSITION)
!
!    SELECT PREVIOUS(DISP=-1)=I.A.4    AND SELECT NEXT(DISP=+1)=I.A.3
!
ACT0POS(0):%IF DISP=-1 %THEN %START
               %IF TCB_PTR=TCB_STARTOFDATA %THEN RC=-9015 %AND ->RETURN
               %IF TCB_BSINDEX=-1 %THEN RC=200020 %AND ->RETURN
               TCB_PTR=TCB_BSINDEX ; TCB_BSINDEX=-1
               RC=0
               ->RETURN
               %FINISH
         %IF DISP=+1 %THEN %START
               %IF TCB_PTR=TCB_ENDOFDATA %THEN RC=-9015 %AND ->RETURN
               %IF TCB_PTR=-1 %THEN TCB_PTR=TCB_STARTOFDATA %AND %C
                                        RC=0 %AND ->RETURN
               TCB_BSINDEX=TCB_PTR
               TCB_CURRENTLENGTH=0
               MOVE(2,TCB_PTR,ADDR(TCB_CURRENTLENGTH)+2)
               TCB_PTR=TCB_PTR+TCB_CURRENTLENGTH
          RC=0
               ->RETURN
               %FINISH
     RC=200021;->RETURN
!
!          SELECT JUST AFTER LAST    I.A.=2
!
ACT0POS(1):TCB_PTR=TCB_ENDOFDATA
            TCB_BSINDEX=-1
         RC=-9015
         ->RETURN
!
!      SELECT JUST BEFORE FIRST
!
ACT0POS(2):TCB_PTR=-1
         RC=-9015
         ->RETURN
!
!         SELECT JUST BEFORE CURRENT  I.A.5
!
ACT0POS(3):%IF TCB_PTR=TCB_STARTOFDATA %THEN %START
               TCB_PTR=-1
      TCB_BSINDEX=-1
         RC=0
         ->RETURN
         %FINISH
      %IF TCB_BSINDEX=-1 %THEN RC=200020 %AND ->RETURN
         TCB_PTR=TCB_BSINDEX 
      TCB_BSINDEX=-1
      RC=0
      ->RETURN
!
!     SELECT BY KEY
!
ACT0POS(4):RC=9077
      ->RETURN
!
!         SELECT NEXT AND READ (I.A.=7) AND SELECTPREVIOUS AND READ (I.A.=8)
!
ACT1:->ACT1POS(POSITION)
!
ACT1POS(0):%IF DISP=+1 %THEN %START
      %IF TCB_PTR=-1 %THEN TCB_PTR=TCB_STARTOFDATA %ELSE %START
         TCB_BSINDEX=TCB_PTR
      TCB_CURRENTLENGTH=0
      MOVE(2,TCB_PTR,ADDR(TCB_CURRENTLENGTH)+2)
      TCB_PTR=TCB_PTR+TCB_CURRENTLENGTH
      %FINISH
      !
!    CHECK FOR END OF FILE
!
         %IF TCB_PTR=TCB_ENDOFDATA %THEN RC=9034 %AND ->RETURN
      LENGTH=0
      MOVE(2,TCB_PTR,ADDR(LENGTH)+2)
      RECLENGTH=LENGTH-2
!      %IF RECLENGTH > TCB_BUFFERLENGTH  %THEN RC=9092 %AND ->RETURN
      MOVE(TCB_BUFFERLENGTH,TCB_PTR+2,TCB_BUFFERADDRESS)
!
!       ITOE FOR  ALL AT THE MOMENT
!
ITOE(TCB_BUFFERADDRESS,TCB_BUFFERLENGTH)
      %IF TCB_RECSIZEADD#-1 %THEN %C
INTEGER(TCB_RECSIZEADD)=TCB_BUFFERLENGTH
      RC=0
      ->RETURN
      %FINISH
%IF DISP=-1 %THEN %START

         %IF TCB_PTR=TCB_STARTOFDATA %THEN RC=9034 %AND ->RETURN
      %IF TCB_BSINDEX=-1 %THEN RC=200020 %AND ->RETURN
      TCB_PTR=TCB_BSINDEX
      TCB_BSINDEX=-1
      LENGTH=0
      MOVE(2,TCB_PTR,ADDR(LENGTH)+2)
      RECLENGTH=LENGTH-2
!      %IF RECLENGTH>TCB_BUFFERLENGTH %THEN RC=9092 %AND ->RETURN
      MOVE(TCB_BUFFERLENGTH,TCB_PTR+2,TCB_BUFFERADDRESS)
!
!   ITOE  FOR THIS 
!
ITOE(TCB_BUFFERADDRESS,TCB_BUFFERLENGTH)
      %IF TCB_RECSIZEADD#-1 %THEN %C
INTEGER(TCB_RECSIZEADD)=TCB_BUFFERLENGTH
      RC=0
      ->RETURN
         %FINISH
!
!     SELECT BY KEY AND READ  I.A.=
!
ACT1POS(4):RC=9077;->RETURN
!
!
!      SELECT NEXT AND NEWWRITE(AT END) I.A. 10
!
ACT2POS(0):%IF TCB_PTR#TCB_ENDOFDATA %THEN RC=9043 %AND ->RETURN
      RECLENGTH=0
      %IF TCB_RECSIZEADD#-1 %THEN RECLENGTH=INTEGER(TCB_RECSIZEADD) %C
 %ELSE %C
                                       RECLENGTH=TCB_BUFFERLENGTH
      RECLENGTH=RECLENGTH+2
      %IF TCB_PTR+RECLENGTH>TCB_ENDOFFILE %THEN %C
               RC=9040 %AND ->RETURN
      MOVE(2,ADDR(RECLENGTH)+2,TCB_PTR)
      MOVE(RECLENGTH-2,TCB_BUFFERADDRESS,TCB_PTR+2)
!
!       ETOI
!
ETOI(TCB_PTR+2,RECLENGTH-2)
      TCB_BSINDEX=TCB_PTR
      TCB_PTR=TCB_PTR+RECLENGTH
      TCB_ENDOFDATA=TC B_PTR
      !
!    UPDATE FILEHEADER INFO EACH TIME
!
INTEGER(TCB_CONNECTADDRESS)=TCB_ENDOFDATA-TCB_CONNECTADDRESS
INTEGER(TCB_CONNECTADDRESS+28)=INTEGER(TCB_CONNECTADDRESS+28)+1
RC=0
      ->RETURN
!
!      SELECT BY KEY AND NEWWRITE
!
ACT2POS(4):RC=9077;->RETURN
!
!     OVERWRITE CURRENT  ONLY ALLOWED IF RECORDS EXACTLY SAME LENGTH
!
ACT(8):%IF TCB_PTR=TCB_ENDOFDATA %THEN RC=9040 %AND ->RETURN
      LENGTH=0;MOVE(2,TCB_PTR,ADDR(LENGTH)+2)
    RECLENGTH=INTEGER(TCB_RECSIZEADD)
      %IF RECLENGTH # LENGTH %THEN RC=9041 %AND ->RETURN
      MOVE(RECLENGTH-2,TCB_BUFFERADDRESS,TCB_PTR+2)
!
!    ETOI
!
ETOI(TCB_PTR+2,RECLENGTH-2)
      RC=0
      ->RETURN
!
!       EXTENDED DESTROY FROM CURRENT   I.A.=16
!
ACT(11):%IF TCB_PTR=-1 %THEN TCB_PTR=TCB_STARTOFDATA %AND %C
                                 RC=0 %AND ->RETURN
%IF TCB_PTR#TCB_ENDOFDATA %THEN %START
      TCB_BSINDEX=TCB_PTR
      LENGTH=0;MOVE(2,TCB_PTR,ADDR(LENGTH)+2)
      TCB_PTR=TCB_PTR+LENGTH
      TCB_ENDOFDATA=TCB_PTR
     %FINISH
      !
!      UPDATE LENGTH OF FILE  TOO BAD ABOUT RECORD COUNT FOR NOW
!
INTEGER(TCB_CONNECTADDRESS)=TCB_ENDOFDATA-TCB_CONNECTADDRESS
RC=0
      ->RETURN
!
!       READ KEY INTO KEY BUFFER
!
ACT(16):RC=9077
      ->RETURN
!
!        DESELECTRAM
!
ACT(12):RC=DESELECTRAM(INDEX)
        ->RETURN
!
!     COMMON RETURN POINT
!
RETURN:!EXITREP("PERFORMIO",RC)
%RESULT=RC
%END
!*****************************************************************
!
!                       DESELECTRAM
!
!******************************************************************
%INTEGERFN DESELECTRAM(%INTEGER INDEX)
!
!          SETS VALUES IN EMAS FILE HEADER TO 'CLOSE' FILE
!
%INTEGER CONAD
%RECORDNAME TCB(FCBFORMAT)
TCB==FCB(INDEX)
!
!     CHECK FOR WRITE ACCESS
!
%IF JSV(TCB_JSVPTR)_ACCESS&2#0 %THEN %START
CONAD=TCB_CONNECTADDRESS
INTEGER(CONAD)=TCB_ENDOFDATA-TCB_CONNECTADDRESS
!INTEGER(CONAD+32)='DATEANDTIME'
!INTEGER(CONAD+40)='NUMBER OF RECORDS'
INTEGER(CONAD+8)=(INTEGER(CONAD)+4095)&X'FFFFF000'
%FINISH
!
!         RESET VALUES IN FCB TO INDICATE FILECLOSED
!
TCB_OPEN=0
%RESULT=0
%END
!*********************************************************************
!
!                           CTMJSREAD
!
!**********************************************************************
%EXTERNALINTEGERFN CTMJSREAD(%INTEGER NAMDR0,NAMDR1,INTDR0,INTDR1, %C
STRDR0,STRDR1,DUM0,DUM1)
!
!  READS JOBSPACE VARIABLE
!     IF INT PARAMETER IS NOT NIL JSV_IVALUE IS RETURNED
!      IF STRING PARAMETER IS NOT NIL JSV_NAME IS RETURNED
!     THE INDEX IN JSV IS RETURNED TO THE INTEGER WHOSE
!    ADRRESS IS GIVEN IN DUM1
!
%STRING(32) NAME
%INTEGER I,L,LS,RC
%INTEGER X
NAME=STRINGFROM(NAMDR0,NAMDR1) ; NAME=DESPACED(NAME)
!
!?;*STLN_X
!?;TRACE("CTMJSREAD",NAME,X,8)
!?
%IF JSN#0 %THEN %START
%CYCLE I=1,1,JSN
%IF NAME=JSV(I)_LNAME %THEN %START
      %IF DUM1#NIL %THEN MOVE(4,ADDR(I),DUM1)
      %IF INTDR0#NIL %THEN MOVE(8,ADDR(JSV(I)_IVALUE),INTDR1)
      %IF STRDR0#NIL %THEN %START
         L=LENGTH(JSV(I)_NAME)
         LS=STRDR0&X'00FFFFFF'
         %IF LS < L %THEN L=LS %AND RC=-9105
         FILL(LS,STRDR1,EBCDICSPACE)
         MOVE(L,ADDR(JSV(I)_NAME)+1,STRDR1)
         %FINISH
      RC=0
      ->RETURN
      %FINISH
%REPEAT
%FINISH
RC=200000
RETURN:EXITREP("CTMJSREAD",RC)
%RESULT=RC
%END
!*********************************************************************
!
!                                     CTMJSWRITE
!
!**************************************************************************
!
%EXTERNALINTEGERFN CTMJSWRITE(%INTEGER NAMDR0,NAMDR1,INTDR0,INTDR1, %C
STRDR0,STRDR1,DUM0,DUM1)
!
!    WRITES JOBSPACE VARIABLES TO JSV_IVALUE OR JSV_NAME
!  IF NAME EXISTS OVERWRITE VALUE , IF NAME DOES NOT EXIST
!  THENM ADD NAME TO LIST AND INSERT APPROPRIATE VALUE
!
%STRING(32) NAME
%INTEGER I,J,X,RC
NAME=STRINGFROM(NAMDR0,NAMDR1) ; NAME=DESPACED(NAME)
!?;*STLN_X
!?;TRACE("CTMJSWRITE",NAME,X,8)
J=JSN+1
%IF JSN#0 %THEN %START
%CYCLE I=1,1,JSN
%IF NAME=JSV(I)_LNAME %THEN J=I %AND %EXIT
%REPEAT
%FINISH
!
%IF INTDR0#NIL %THEN %START
      MOVE(8,INTDR1,ADDR(JSV(J)_IVALUE))
%FINISH
%IF STRDR0#NIL %THEN %START
      JSV(J)_NAME=STRINGFROM(STRDR0,STRDR1)
%FINISH
!
!   UPDATE NAME ENTRY IF NECESSARY
!
%IF J=JSN+1 %THEN JSN=JSN+1 %AND JSV(J)_LNAME=STRINGFROM(NAMDR0,NAMDR1)
!
! TEST FOR OVERFLOW OF TABLE
!
%IF JSN=JSMAX %THEN RC=200001 %ELSE RC=0
!?;EXITREP("CTMJSWRITE",RC)
%RESULT=RC
%END
!**********************************************************************
!
!                                    CTMJSDECLARE
!
!**************************************************************************
!
%EXTERNALINTEGERFN CTMJSDECLARE(%INTEGER NAMDR0,NAMDR1,INTDR0,INTDR1, %C
STRDR0,STRDR1,DUM0,DUM1)
!
!   CODED AS IDENTICAL TO CTMJSWRITE
!
%EXTERNALINTEGERFNSPEC CTMJSWRITE(%INTEGER N0,N1,I0,I1,S0,S1,D0,D1)
%RESULT=CTMJSWRITE(NAMDR0,NAMDR1,INTDR0,INTDR1,STRDR0,STRDR1, %C
DUM0,DUM1)
%END
!************************************************************************
!
!                                CTMLOG
!
!****************************************************************************
!
%EXTERNALINTEGERFN CTMLOG(%INTEGER MESSAGETYPE,DUM0,MESDR0,MESDR1)
!
!
! SENDS MESSAGE TO LOG STREAM
!
%STRING(120) MESSAGE
%INTEGER I,X,RC,CURRENTSTREAM
!?;*STLN_X
!?;TRACE("CTMLOG","",X,4)
CURRENTSTREAM=OUTSTREAM
SELECTOUTPUT(LOGSTREAM)
NEWLINE
WRITE(MESSAGETYPE,5);SPACES(5)
I=MESDR0&X'00FFFFFF'
%IF I>120 %THEN I=120
MESSAGE=STRINGFROM(I,MESDR1)
ETOI(ADDR(MESSAGE)+1,LENGTH(MESSAGE))
PRINTSTRING(MESSAGE)
SELECTOUTPUT(CURRENTSTREAM)
RC=0
!?;EXITREP("CTMLOG",RC)
%RESULT=RC
%END
!*****************************************************************************
!
!                            CTMDATETIME
!
!*****************************************************************************
!
%EXTERNALINTEGERFN CTMDATETIME(%LONGINTEGER INPUTTIME, %C
%INTEGER DATEDR0,DATEDR1,TIMEDR0,TIMEDR1,DUM0)
%EXTERNALSTRINGFNSPEC TIME
%EXTERNALSTRINGFNSPEC DATE
!
!   IF INPUT TIME #0 THE ROUTINE SHOULD CONVERT INPUT TIME
!   TO DATE AND TIME IN CHARACTER FORMAT. FOR THE
!   THE MOMENT THIS OPTION IS IGNORED AND THE CURRECT DATE AND TIME
!   ARE RETURNED .
!
%INTEGER X,RC
%STRING(10) S,D,M,Y
!?;*STLN_X
!?;TRACE("CTMDATETIME","",X,6)
S=TIME;ITOE(ADDR(S)+1,LENGTH(S))
MOVE(8,ADDR(S)+1,TIMEDR1)
!
S=DATE
S->D.("/").M.("/").Y
S="19".Y."/".M."/".D
ITOE(ADDR(S)+1,10)
MOVE(10,ADDR(S)+1,DATEDR1)
RC=0
!?;EXITREP("CTMDATETIME",RC)
%END
!*************************************************************************
!
!                 CTMASSIGNFILE
!
!******************************************************************************
%EXTERNALINTEGERFN CTMASSIGNFILE(%INTEGER FRDR0,FRDR1,LNDR0,LNDR1, %C
      FNDR0,FNDR1,ACCESS,LOCK,NRA,NRB0,NRB1,START,END %C
      %LONGINTEGER ROUTE,NRC %INTEGER NRD0,NRD1,NRE0,NRE1)
!
!     ONLY PARAMETERS USED AT THE MOMENT ARE FILEROUTE,LOCALFILENAME,
!       AND FULL FILENAME. I.E. THE FIRST 3 SETS OF DESCRIPTORS.
!     THE ROUTINE SETS UP VALUES IN JSV_NAME AND JSV_LNAME
!    AND SELECTS NEXT FCB BLOCK FOR USE WITH FILE.
!   JSV_LNAME=LOCAL FILENAME , JSV_IVALUE=FCB INDEX AND JSV_NAME=FILENAME
!
%LONGINTEGER FCBINDEX
%INTEGER RC,FCBDR0,FCBDR1
%EXTERNALINTEGERFNSPEC CTMJSWRITE(%INTEGER NAMDR0,NAMDR1,INTDR0, %C
      INTDR1,STRDR0,STRDR1,DUM0,DUM1)
%STRING(32) NAME
%INTEGER X
NAME=STRINGFROM(FNDR0,FNDR1) ; NAME=DESPACED(NAME)
!?;*STLN_X
!?;TRACE("CTMASSIGNFILE",NAME,X,19)
!?
%IF FCN=FCMAX %THEN RC=200002 %AND ->RETURN
FCN=FCN+1 ; FCBINDEX=FCN
FCBDR0=X'30000001' ; FCBDR1=ADDR(FCBINDEX)
RC=CTMJSWRITE(LNDR0,LNDR1,FCBDR0,FCBDR1,FNDR0,FNDR1,-1,-1)
%IF RC=0 %THEN MOVE(8,FCBDR1,FRDR1)
RETURN:
!?;EXITREP("CTMASSIGNFILE",RC)
%RESULT=RC
%END
!************************************************************************
!
!        CTMSELECTRAM
!
!****************************************************************************
%EXTERNALINTEGERFN CTMSELECTRAM(%LONGINTEGER ROUTE %C
      %INTEGER LNDR0,LNDR1,PDR0,PDR1)
!
!     FILE IS INDICATED EITHER BY ROUTE OR LOCALNAME
!     IF NO ASSIGNFILE HAS BEEN ISSUED NO FCB INDEX WILL
!    HAVE BEEN ALLOCATED AND NO FILE MAY EXIST.
!   THE ROUTINE CHECKS IF ROUTE IS NONZERO THEN FCBINDEX=ROUTE
!    AND INITIALISATION PROCEEDS. IF ROUTE=0  JSV_LNAME IS SEARCHED
!    FOR A MATCH WITH LOCAL NAME. IF IT IS FOUND THEN 
!    JSV_IVALUE WILL CONTAIN FCBINDEX, IF THE FILE DOES NOT
!       EXIST A FILE IS CREATED VIA OUTFILE.
!
%EXTERNALROUTINESPEC PP(%INTEGER INDEX,DR0,DR1)
%RECORDNAME TCB(FCBFORMAT)
%LONGINTEGER LI
%INTEGER I,J,INDEX,RC,X,HOLE,PROTECT,FLAG,MODE,FILESIZE,DR0,DR1
%INTEGER ENDOFFILE
%STRING(32) NAME
%RECORDFORMAT RF(%INTEGER CONAD,FILETYPE,DATASTART,DATAEND)
%RECORD R(RF)
%SWITCH ACC(1:9)
NAME=STRINGFROM(LNDR0,LNDR1);NAME=DESPACED(NAME)
!?;*STLN_X
!?;TRACE("CTMSELECTRAM",NAME,X,5)
!       OBTAIN INDEX IN FCB AND IN JSV
!
!
PROTECT=0;FLAG=0
%IF ROUTE#0 %THEN INDEX=ROUTE      %ELSE %START
      RC=CTMJSREAD(LNDR0,LNDR1,0,ADDR(LI),-1,-1,-1,ADDR(J))
    %IF RC=0 %THEN INDEX=LI      %ELSE RC=9087 %AND ->RETURN
      %FINISH
!
!   SET UP TCB TO POINT TO RELEVANT FCB
!
TCB==FCB(INDEX)
!
!  CHECK FILE EXISTS AND CONNECT IT
!
NAME=JSV(J)_NAME
MODE=JSV(J)_ACCESS
FILESIZE=JSV(J)_SIZE
HOLE=FILESIZE
CONNECT(NAME,MODE,HOLE,PROTECT,R,FLAG)
%IF FLAG=0 %THEN ->FILEEXISTS
%IF FLAG=218 %THEN ->CREATEFILE
!
!      FAILURE TO CONNECT FILE
!
LOG("CONNECT FAILS FOR FILE ".NAME."  ".SFROMI(FLAG))
RC=9087;->RETURN
CREATEFILE:OUTFILE(NAME,FILESIZE,HOLE,PROTECT,R_CONAD,FLAG)
%IF FLAG=0 %THEN %START
INTEGER(R_CONAD+12)=4
INTEGER(R_CONAD+24)=X'4000002'
R_FILETYPE=INTEGER(R_CONAD+12)
R_DATASTART=INTEGER(R_CONAD+4)
R_DATAEND=INTEGER(R_CONAD)
    %FINISH %ELSE %START
LOG("FAILURE TO CREATE FILE".NAME."  ".SFROMI(FLAG))
RC=9087;->RETURN
%FINISH
FILEEXISTS:ENDOFFILE=R_CONAD+FILESIZE-1
!
!      INITIALISE FURTHER FIELDS IN FCB
!
!      ACCESS 1 AND ACCESS 2 ADDRESSES VIA RTNDESC ROUTINE
!
->ACC(INDEX)
ACC(1):TCB_ACCESS1=RTNDESC(ACCESS11)
      TCB_ACCESS2=RTNDESC(ACCESS21)
      ->CONT
ACC(2):TCB_ACCESS1=RTNDESC(ACCESS12)
      TCB_ACCESS2=RTNDESC(ACCESS22)
      ->CONT
ACC(3):TCB_ACCESS1=RTNDESC(ACCESS13)
      TCB_ACCESS2=RTNDESC(ACCESS23)
      ->CONT
ACC(4):TCB_ACCESS1=RTNDESC(ACCESS14)
      TCB_ACCESS2=RTNDESC(ACCESS24)
      ->CONT
ACC(5):TCB_ACCESS1=RTNDESC(ACCESS15)
      TCB_ACCESS2=RTNDESC(ACCESS25)
      ->CONT
ACC(6):TCB_ACCESS1=RTNDESC(ACCESS16)
      TCB_ACCESS2=RTNDESC(ACCESS26)
      ->CONT
ACC(7):TCB_ACCESS1=RTNDESC(ACCESS17)
      TCB_ACCESS2=RTNDESC(ACCESS27)
      ->CONT
ACC(8):TCB_ACCESS1=RTNDESC(ACCESS18)
      TCB_ACCESS2=RTNDESC(ACCESS28)
      ->CONT
ACC(9):TCB_ACCESS1=RTNDESC(ACCESS19)
      TCB_ACCESS2=RTNDESC(ACCESS29)
      ->CONT
CONT:TCB_CONNECTADDRESS=R_CONAD
TCB_STARTOFDATA=R_CONAD+R_DATASTART
TCB_ENDOFDATA=R_CONAD+R_DATAEND
TCB_OPEN=1
TCB_BSINDEX=-1
TCB_FILETYPE=4
TCB_ENDOFFILE=ENDOFFILE
!
!      SET UP DEFAULTS AS IN TABLE 8 OF CTM DEFINITION
!
TCB_ACTION=-1
TCB_POSITION=0
TCB_DISPLACEMENT=1
TCB_RECORDBUFF0=-1
TCB_RECORDBUFF1=-1
TCB_KEYBUFFER=-1
TCB_RECSIZEADD=-1
TCB_MAXREC=1024
TCB_PTR=-1      ;!    SET PTR TO START OF FILE BY DEFAULT
!
!     PROCESS PARAMETER PAIRS
!
PP(INDEX,PDR0,PDR1)
RC=0
RETURN:EXITREP("CTMSELECTRAM",RC)
%RESULT=RC
%END
!***************************************************************************
!
!                              CTMREADDESC
!
!****************************************************************
%EXTERNALINTEGERFN CTMREADDESC(%LONGINTEGER ROUTE, %C
%INTEGER LNDR0,LNDR1,FNDR0,FNDR1,PDR0,PDR1)
!
!  IDENTIFY FCB INDEX VIA ROUTE OR LOCALFILENAME
!    ONLY PARAMETERS RECOGNISED ARE 104 106 107 126
!
%STRING(32) NAME
%INTEGER I,J,K,RC,X,N,A,CURRENTSTREAM
%LONGINTEGER LI
NAME=STRINGFROM(LNDR0,LNDR1) ; NAME=DESPACED(NAME)
!?;*STLN_X
!?;TRACE("CTMREADDESC",NAME,X,7)
!
%IF ROUTE#0 %THEN I=ROUTE %ELSE %START
%IF LNDR0#NIL %THEN %START
      RC=CTMJSREAD(LNDR0,LNDR1,0,ADDR(LI),-1,-1,-1,-1)
      %IF RC#0 %OR LI=0 %THEN RC=9087 %AND ->RETURN
      I=LI
      %FINISH %ELSE %START
      NAME=STRINGFROM(FNDR0,FNDR1);NAME=DESPACED(NAME)
      LI=-1
  %IF JSN=0 %THEN RC=9087 %AND ->RETURN
      %CYCLE J=1,1,JSN
   %IF NAME=JSV(J)_NAME %THEN LI=JSV(J)_IVALUE %AND %EXIT
      %REPEAT
      %IF LI=-1 %THEN RC=9087 %AND ->RETURN
      I=LI
      %FINISH
      %FINISH
!
!   I NOW CONTAINS INDEX IN FCB ARRAY
!   LOOK AT PARAMETER PAIRS
!
N=(PDR0&X'00FFFFFF')//3
!?;CURRENTSTREAM=OUTSTREAM;SELECTOUTPUT(TRACESTREAM)
%CYCLE J=1,1,N
A=PDR1+12*(J-1)
K=INTEGER(A)
%IF K=104 %THEN INTEGER(A+4)=1024
%IF K=106 %THEN INTEGER(A+4)=FCB(I)_KEYPOSN
%IF K=107 %THEN INTEGER(A+4)=FCB(I)_KEYLENGTH
%IF K=126 %THEN INTEGER(A+4)=FCB(I)_RECORDVIEW
!?;NEWLINE;WRITE(K,5);PRINTSTRING(HEXOF(INTEGER(A+4)));
!?;PRINTSTRING(HEXOF(INTEGER(A+8)));
%REPEAT
!?;SELECTOUTPUT(CURRENTSTREAM);NEWLINE
RC=0
RETURN:EXITREP("CTMREADDESC",RC)
%RESULT=RC
%END
!************************************************************************
!
!                           CTMSTOP
!
!*****************************************************************************
%EXTERNALINTEGERFN CTMSTOP(%LONGLONGREAL LL %INTEGER RESPONSE)
%INTEGER RC,X,I,J,K,L
!?;*STLN_X
!?;TRACE("CTMSTOP","",X,1)
!     RETURN TO CALLER
!
COMREG(34)=CREG34
COMREG(36)=CREG36
I=QUIT LNB
K=QUIT CTB
L=QUIT XNB
*LCT_K
*LXN_L
*LLN_I
*LSS_0
*EXIT_-64
%RESULT=0

%END
!*****************************************************************************
!
!                     CTMDUMP
!
%EXTERNALINTEGERFN CTMDUMP(%LONGINTEGER MESSAGE, %C
%INTEGER DUM0,DUM1,ADDR0,ADDR1,DUM2,DUM3,OPTIONS, %C
%LONGINTEGER DUMPROUTE)
!
%INTEGER RC,X
!?;*STLN_X
!?;TRACE("CTMDUMP","",X,9)
%MONITOR ;%STOP
%END
!******************************************************************************
!
!                             CTMSETVSATT
!
!****************************************************************************
%EXTERNALINTEGERFN CTMSETVSATT(%LONGINTEGER DESCRIPTOR, %C
   %INTEGER PDR0,PDR1)
!
!      CHANGES PROPERTIES OF AREAS
!     JUST TRACE IT FOR THE MOMENT
!
!***************************************************************************
%INTEGER RC,X
!?;*STLN_X
!?;TRACE("CTMSETVSATT","",X,3)
!
RC=0
!?;EXITREP("CTMSETVSATT",RC)
%RESULT=RC
%END
!****************************************************************************
!
!                          CTMINFORM
!
!****************************************************************************
%EXTERNALINTEGERFN CTMINFORM(%INTEGER CLASS, %LONGINTEGER INTPROC, %C
     %INTEGER MASK,INSTLIMIT)
!
!        SETS UP ENTRIES TO INTERRUPT P[ROCEDURES
!
%INTEGER RC,X
!?;*STLN_X
!?;TRACE("CTMINFORM","",X,4)
!
!      DUMMY ROUTINE FOR THE MOMENT
!
RC=0
EXITREP("CTMINFORM",RC)
%RESULT=0
%END
!***************************************************************************
!
!                                CTMSIGNAL
!
!****************************************************************************
%EXTERNALINTEGERFN CTMSIGNAL(%INTEGER CONTINGENCY, %C
     %LONGINTEGER MESSAGE,NRA %INTEGER NRB0,NRV1)
!
!     USED TO SIMULATE EFFECT OF A CINTNGENCY
!
%INTEGER RC,X
!?;*STLN_X
!?;TRACE("CTMSIGNAL","",X,5)
RC=0
EXITREP("CTMSIGNAL",RC)
%RESULT=RC
%END
!***********************************************************************!
!                            CTMLOAD
!
!******************************************************************************
%EXTERNALINTEGERFN CTMLOAD(%INTEGER MDR0,MDR1,DSC0,DSC1,OPTIONS)
!
!    THIS ASSUMES THAT THE REQUIRED MODULES ARE LOADED AND
!   INSPECTS THE LOADER TABLES VIA FINDENTRY ROUTINE
!      PREFIXES ARE STRIPPED FROM NAMES BEFORE SEARCH
!
%INTEGER X,RC,NMNAMES,NDSCS
!
!   DTOSTRING - CREATES STRING IN S CORRESPONDING TO BYTE 
!     DESCRIPTOR IN D
!
%ROUTINE DTOSTRING(%LONGINTEGER D %STRINGNAME S)
%LONGINTEGER TEMP
%INTEGER L,AD,I
%IF D=-1 %THEN S="" %AND %RETURN
L=(X'00FFFFFF00000000'&D)>>32
BYTEINTEGER(ADDR(S))=L
TEMP=X'00000000FFFFFFFF'&D
AD=TEMP
%IF L=0 %THEN %RETURN
%CYCLE I=1,1,L
BYTEINTEGER(ADDR(S)+I)=BYTEINTEGER(AD+I-1)
%REPEAT
%END
!
!   DTOSARRAY - CREATES STRING ARRAY FROM REF() REF() BYTE 
!  DESCRIPTOR IN D
!
%ROUTINE DTOSARRAY(%LONGINTEGER D %STRINGARRAYNAME S %INTEGERNAME COUNT)
%LONGINTEGER TEMP
%INTEGER L,AD,I
COUNT=0
%IF D=-1 %THEN %RETURN
L=(X'00FFFFFF00000000'&D)>>32
TEMP=X'00000000FFFFFFFF'&D
AD=TEMP
%IF L=0 %THEN %RETURN
%CYCLE I=1,1,L
MOVE(8,AD+8*(I-1),ADDR(TEMP))
DTOSTRING(TEMP,S(I))
%REPEAT
COUNT=L
%END
!?;*STLN_X
!?;TRACE("CTMLOAD","",X,5)
NMNAMES=X'000000FF'&MDR0
NDSCS=X'000000FF'&DSC0
%IF NMNAMES>NDSCS %THEN NMNAMES=NDSCS
%BEGIN
%LONGINTEGER LI
%INTEGER I,FLAG,L0,L1
%STRING(32) %ARRAY MNAMES(1:NMNAMES)
%STRING(32)S,T
LI=(LENGTHENI(MDR0)<<32)!MDR1
DTOSARRAY(LI,MNAMES,I)
!?;SELECTOUTPUT(TRACESTREAM)
!?;NEWLINE;PRINTSTRING("CTMLOAD LIST");NEWLINE
!?;%CYCLE I=1,1,NMNAMES;PRINTSTRING(MNAMES(I));NEWLINE;%REPEAT
RC=0
%CYCLE I=1,1,NMNAMES
MNAMES(I)->S.(".").T ;!REMOVE PREFIX
L0=X'30000001';L1=ADDR(LI)
FINDENTRY(T,0,0,LIBFILNAME,L0,L1,FLAG)
%IF FLAG=0 %THEN MOVE(8,ADDR(LI),DSC1+8*(I-1)) %C
%ELSE RC=-9101
%REPEAT
%END
!?;EXITREP("CTMLOAD",RC)
%RESULT=RC
%END
!*************************************************************************
!*******************************************************************************
!
!      OPEH INTERFACE SYSTEM
!
!****************************************************************************
!*****************************************************************************
%EXTERNALINTEGERFN ICL9HEPROLOG(%INTEGER I)
%INTEGER X,RC
!?;*STLN_X
!?;TRACE("ICL9HEPROLOG","",X,1)
RC=0
!?;EXITREP("ICL9HEPROLOG",RC)
%RESULT=0
%END
!****************************************************************************
!
!                          ICL9HECOMPERR
!
!*****************************************************************************
%EXTERNALINTEGERFN ICL9HECOMPERR(%INTEGER LANGUAGE,ERRORNO)
%INTEGER X,RC
!?;*STLN_X
!?;TRACE("ICL9HECOMPERR","",X,2)
SELECTOUTPUT(TRACESTREAM)
NEWLINE;PRINTSTRING(HEXOF(LANGUAGE))
WRITE(ERRORNO,10);NEWLINE
%MONITOR
%STOP
RC=0
%RESULT=0
%END
!****************************************************************************
!
!                               ICL9HEFATALCOMPERR
!
!****************************************************************************
%EXTERNALINTEGERFN ICL9HEFATALCOMPERR(%INTEGER LANGUAGE,ERRORNO)
%INTEGER X,RC,CURRENTSTREAM
!?;*STLN_X
!?;TRACE("ICL9HEFATALCOMPERR","",X,2)
CURRENTSTREAM=OUTSTREAM
SELECTOUTPUT(TRACESTREAM)
NEWLINE;PRINTSTRING(HEXOF(LANGUAGE))
WRITE(ERRORNO,10);NEWLINE
%MONITOR
%STOP
%RESULT=0
%END
!*****************************************************************************
!
!                              ICL9HERROR(%INTEGER DUMMY)
!
!*****************************************************************************
!
!     NOT REQUIRED JUST YET
!
!****************************************************************************
!
!                             ICL9HEREPORT
!
!*******************************************************************************
!
!     NOT REQUIRED
!
!********************************************************************************
!
!                      ICL9LDLIBPROC
!
!****************************************************************************
!*****************************************************************************
!
!                            ICL9HEINTPROC
!
!****************************************************************************
!****************************************************************************
!
!                            ICL9HENOMDESC
!
!*****************************************************************************
%EXTERNALINTEGERFN ICL9HENOMDESC(%INTEGER PDR0,PDR1, %C
 %LONGLONGREAL REFPROC)
%INTEGER RC,X
!?;*STLN_X
!?;TRACE("ICL9HENOMDESC","",X,3)
RC=0
!?;EXITREP("ICL9HENOMDESC",RC)
%RESULT=RC
%END
!****************************************************************************
!
!                             ICL9HEFILETIDYPROC
!
!****************************************************************************
%EXTERNALINTEGERFN ICL9HEFILETIDYPROC(%LONGINTEGER FILETIDYPROC)
%INTEGER RC,X
!?;*STLN_X
!?;TRACE("ICL9HEFILETIDYPROC","",X,1)
RC=0
!@?;EXITREP("ICL9HEFILETIDYPROC",RC)
%RESULT=0
%END
!***************************************************************************
!
!                              ICL9HETIDYUP
!
!******************************************************************************
%EXTERNALINTEGERFN ICL9HETIDYUP
%INTEGER RC,X
!?;*STLN_X
!?;TRACE("ICL9HETIDYUP","",X,1)
!    NOTE THIS ROUTINE HAS NO PARAMETERS WHEN CALLED
!     WILL NEED FIDDLING.
!
RC=0
!?;EXITREP("ICL9HETIDYUP",RC)
%RESULT=RC
%END
!*****************************************************************
!
!                                COBRUN
!
!***************************************************************************
%EXTERNALROUTINE COBRUN(%STRING(255) S)
%OWNSTRING(31) JSFILENAME="COB#JSV"
%INTEGER I,J,K,L
!
!     SAVE REGISTERS FOR A RETURN TO CALLER
!
*STCT_I
*STXN_J
QUITCTB=I
QUITXNB=J
*STLN_K
QUITLNB=K
CREG34=COMREG(34)
CREG36=COMREG(36)
!
!    SET UP LOGSTREAM AND TRACESTREAM
!
LOGSTREAM=0
TRACESTREAM=79
DEFINE("79,COB#TRACE")
!
!   CONNECT JSV FILE
!
I=CONNECTJSFILE(JSFILENAME)
%IF I<0 %THEN ->FAULT1
JSV==ARRAY(I,JSVAF)
JSN==JSV(0)_IVALUE
!
!   PRINT OUT JOBSPACE VARIABLES
!
SELECTOUTPUT(LOGSTREAM)
%IF JSN#0 %THEN %START
NEWLINE
PRINTSTRING("JOB SPACE VARIABLES ARE SET AS FOLLOWS:")
NEWLINE
%CYCLE I=1,1,JSN
PRINTSTRING(JSV(I)_LNAME);SPACES(2);
PRINTSTRING(JSV(I)_NAME);SPACES(2)
WRITE(JSV(I)_IVALUE,5)
WRITE(JSV(I)_SIZE,5);WRITE(JSV(I)_KPOS,5);
WRITE(JSV(I)_MAXREC,5);WRITE(JSV(I)_FORMAT,3);WRITE(JSV(I)_ORG,3)
WRITE(JSV(I)_KLEN,3);WRITE(JSV(I)_ACCESS,3);WRITE(JSV(I)_PACKING,3)
NEWLINE
%REPEAT
%FINISH
!
!      ASSIGN FILES TO SET UP LINK FROM JSV_IVALUE TO FCBINDEX
!
!   AT THE MOMENT ALL 'ASSIGNS' ARE CLEARED , AND THEN ALL FILES
!   WHICH HAVE BEEN DEFINED VIA COBDEFINE ARE ALLOCCATED 
!   AN INDEX POSITION IN FCB.    JSV_FORMAT=0 FOR JOB-
!   SPACE VARIABLES WHICH ARE NOT FILES.
!
FCN=0
%CYCLE I=1,1,JSN
%IF JSV(I)_FORMAT#0 %THEN %START
      FCN=FCN+1
      JSV(I)_IVALUE=FCN
      FCB(FCN)_JSVPTR=I   ;!SET LINK FROM FCB TO JSV
      %FINISH
%REPEAT
PARM("LET")
RUN(S)
%STOP
FAULT1:NEWLINE;PRINTSTRING("FAILED TO CONNECT COB#JSV")
NEWLINE
%STOP
%END
!************************************************************************
!
!                               COBDEFINE
!
!**************************************************************************
%EXTERNALROUTINE COBDEFINE(%STRING(127) S)
!
!   SETS UPTABLE OF UNIT DEFINITIONS AND CHANNEL ASSIGNMENTS
!     IN RECORD ARRAY JSV.
!     THIS IS ALSO USED FOR JOBSPACE VARIABLES DEFINED BU
!    COBJSVAR COMMAND, AND IS ACCESSED BY THE COBOL RUN TIME
!    SYSTEM VIA CTMJSREAD ETC.
!
%EXTERNALROUTINESPEC PARMSCAN(%STRINGNAME S ,%INTEGER NPARM, %C
%STRINGARRAYNAME KEYS,LITS, %INTEGERARRAYNAME MODE,PV, %C
%INTEGERNAME LCNT, %INTEGER INITVALUE)
%OWNSTRING(10) %ARRAY KEYS(1:9)="LNAME","NAME","SIZE","RECFM", %C
      "ACC","ORG","KPOS","KLEN","PACKING"
%OWNINTEGERARRAY MODE(1:9)=1,1,0,1,1,1,0,0,0
%OWNINTEGERARRAY INTPARM(1:9)
%STRING(32) %ARRAY LITS(1:10)
%INTEGERARRAY PV(1:9)
%OWNINTEGER INITVALUE=-1
%INTEGER J,LCNT,I,RC
%STRING(32) S2,JSFILENAME
%STRING(1) S1
%INTEGER START,HOLE,PROTECT,CONMODE,FLAG
%OWNSTRING(31) FILENAME="COB#JSV"
JSFILENAME=FILENAME
!
!
!
!
!   CHECK FOR EXISTENCE OF FILE COB#JSV , CREATE ONE IF NOT
!    ALREADY IN EXISTENCE. THEN CONNECT AND MAP RECORD ARRAY ON TO IT
!    NOTE JSV(0)_IVALUE CONTAINS COUNT OF VARIABLES DEFINED
!
I=CONNECTJSFILE(JSFILENAME)
%IF I<0 %THEN ->FAULT1
JSV==ARRAY(I,JSVAF)
!
JSN==JSV(0)_IVALUE
!
!   CHECK FOR PRESENCE OF EACH FILED AND SET RECORD ACCORDINGLY
!
!   FIRST TEST IF JSVAR IS ALREADY SET. I.E. CHECK LNAME FIELD FOR MATCH
!
%CYCLE I=1,1,9;PV(I)=INITVALUE;%REPEAT
PARMSCAN(S,9,KEYS,LITS,MODE,PV,LCNT,INITVALUE)
!
!   LNAME
!
%IF PV(1)=INITVALUE %THEN ->JSVFAULT
S2=LITS(PV(1))
J=-1
%IF JSN#0 %THEN %START
%CYCLE I=1,1,JSN
%IF S2=JSV(I)_LNAME %THEN J=I %AND %EXIT
%REPEAT
%FINISH
%IF J=-1 %THEN JSN=JSN+1 %AND J=JSN 
JSV(J)_LNAME=S2
!
!   NAME
!
%IF PV(2)#INITVALUE %THEN JSV(J)_NAME=LITS(PV(2))
!
!   SIZE
!
%IF PV(3)=INITVALUE %THEN JSV(J)_SIZE=262124 %C
      %ELSE JSV(J)_SIZE=INTPARM(3)*1024
!
!   RECORDFORMAT   INPUT IN FORM <LETTER><INTEGER>
!      E.G.      F2048
!     FIXED = 1  VARIABLE =2    NOTE: FORMAT=0 IMPLIES JOBSPACE
!                                   VARIABLE NOT FILE
!
%IF PV(4)=INITVALUE %THEN JSV(J)_FORMAT=2 %AND JSV(J)_MAXREC=1024 %C
      %ELSE %START
      S1<-LITS(PV(4));LITS(PV(4))->(S1).S2
    %IF S1="F" %THEN JSV(J)_FORMAT=1
      %IF S1="V" %THEN JSV(J)_FORMAT=2
      JSV(J)_MAXREC=IFROMS(S2)
   %FINISH
!
!    ACCESS    READ=1    WRITE=2
!
JSV(J)_ACCESS=1
%IF PV(5)#INITVALUE %AND LITS(PV(5))->("W").S2 %THEN JSV(J)_ACCESS=2
!
!    ORGANISATION  SERIAL=1   RANDOM=2    INDEXSEQUENTIAL=3
!
JSV(J)_ORG=1
%IF PV(6)#INITVALUE %THEN %START
      %IF LITS(PV(6))->("R").S2 %OR LITS(PV(6))->("H").S2 %THEN %C
                  JSV(J)_ORG=2
      %IF LITS(PV(6))->("I").S2 %THEN JSV(J)_ORG=3
           %FINISH
!
!   KEYPOSITION
!
JSV(J)_KPOS=1
%IF PV(7)#INITVALUE %THEN JSV(J)_KPOS=PV(7)
!
!    KEYLENGTH
!
%IF JSV(J)_ORG=1 %THEN JSV(J)_KLEN=0 %C
%ELSE JSV(J)_KLEN=8
%IF PV(8)#INITVALUE %THEN JSV(J)_KLEN=PV(8)
!
!    PACKING
!
%IF PV(9)=INITVALUE %THEN JSV(J)_PACKING=90 %ELSE %C
         JSV(J)_PACKING=PV(9)
!
! RETURN
!
RC=0 ;->RETURN
!
!   FAULT
!
FAULT1:NEWLINE;PRINTSTRING("ERROR IN CONNECTING COB#JSV FILE")
NEWLINE
JSVFAULT:RC=1;
NEWLINE;PRINTSTRING("COBDEFINE : NO LOCAL NAME SPECIFIED")
NEWLINE
RETURN:%END
!***********************************************************************
!
!                               COBJSVAR
!
!******************************************************************************
%EXTERNALROUTINE COBJSVAR(%STRING(63) S)
!
!    FORMAT OF COMMAND IS : COBJSVAR 'JSNAME'!<=,,>!<STRING,INTEGER>
!
!
%INTEGER J,I,RC
%OWNSTRING(31) JSFILENAME="COB#JSV"
%STRING(32) A,B
I=CONNECTJSFILE(JSFILENAME)
%IF I<0 %THEN ->FAULT1
JSV==ARRAY(I,JSVAF)
JSN==JSV(0)_IVALUE
!
%IF S->A.(",").B %OR S->A.("=").B %THEN %START
!
!     LOOK FOR A IN JSV(J)_LNAME
J=-1
%IF JSN#0 %THEN %START
%CYCLE I=1,1,JSN ; %IF A=JSV(I)_LNAME %THEN J=I %AND %EXIT 
%REPEAT
%FINISH
%IF J=-1 %THEN JSN=JSN+1 %AND J=JSN %AND JSV(J)_LNAME=A
!
!    SET JSV_FORMAT=0 TO INDICATE VARIABLE RATHER THAN FILE
!
JSV(J)_FORMAT=0

!
!    CHECK FOR INTEGER OR STRING
!
%IF '0'<= BYTEINTEGER(ADDR(B)+1)<='9' %THEN %C
                                JSV(J)_IVALUE=LENGTHENI(IFROMS(B)) %C
%ELSE JSV(J)_NAME=B
%FINISH %ELSE %START
NEWLINE;PRINTSTRING("COBJSVAR : INCORRECT FORMAT");
      NEWLINE;RC=1
%FINISH
->RETURN
!
!    FAULT
!
FAULT1:NEWLINE;PRINTSTRING("ERROR IN CONNECTING JSVFILE")
NEWLINE
RC=2
RETURN:%END
!***********************************************************************
!
!                            COBCLEAR
!
!****************************************************************************
%EXTERNALROUTINE COBCLEAR
%INTEGER FLAG
DESTROY("COB#JSV,FLAG")
%END
%ENDOFFILE