%BEGIN
%CONTROL X'1FFFFFFF'
!
!    THIS PROGRAM PERFORMS ONE OF TWO ACTIONS DEPENDING ON THE VALUE
!    OF THE INPUT INDICATOR, WHICH MAY BE 1 OR 2.
!
!    IND=1 THE PROGRAM CREATES A NEW MASTER JOURNAL FILE FROM INPUT
!    IN THE FORM SPECIFIED IN THE ROUTINE 'GET TITLE'
!    INPUT MAY BE FROM ANY MEDIUM IF AN APPROPRIATE VERSION OF THE
!    ROUTINE GET TITLE IS PROVIDED.
!
!    IND=2 THE EXISTING MASTER JOURNAL FILE IS READ FROM DISC AND
!    DETAILS ARE PRINTED.
!
!    IN BOTH CASES THE DISC FILE IS EXPECTED ON UNIT 10.
!
%INTEGER MXBUFS                        ;! SIZE OF DISC BUFFER ARRAY
%INTEGER MXNUMB                        ;! MAX SIZE OF TITLE ARRAY
!
MXNUMB = 1024                          ;! SET TITLE ARRAY MAXIMUM       00001200
MXBUFS = 1000                          ;! SET BUFFER ARRAY MAXIMUM
%BEGIN
%EXTERNALROUTINESPEC OPENDA  (%INTEGER CHANNEL)
%EXTERNALROUTINESPEC CLOSEDA (%INTEGER CHANNEL)
%EXTERNALROUTINESPEC READDA  (%INTEGER CHANNEL,%INTEGERNAME SECT,    %C
                              %NAME BEGIN,END)
%EXTERNALROUTINESPEC WRITEDA (%INTEGER CHANNEL,%INTEGERNAME SECT,   %C
                              %NAME BEGIN,END)
%EXTERNALROUTINESPEC SETMARGINS(%INTEGER A,B,C)
!
%ROUTINESPEC GET TITLE (%BYTEINTEGERARRAYNAME JNTITL,                %C
                        %INTEGERNAME JST,JLNG,JNUM)
!
%BYTEINTEGERARRAY JREC(1:500)          ;! INPUT RECORD
%BYTEINTEGERARRAY BUFFER(1:MXBUFS)     ;! DISC O/P BUFFER
!?? ; %HALFINTEGERARRAY MJBPTR(1:MXNUMB)    ;! BLOCK POINTERS
!?? ; %HALFINTEGERARRAY MJPPTR(1:MXNUMB)    ;! POSITION POINTERS
%INTEGERARRAY MJNUMB(1:MXNUMB)         ;! JOURNAL NUMBERS
%INTEGERARRAY CNT(1:6)                 ;! CONTROL ARRAY
!
%INTEGER BLOCK                         ;! CURRENT AVAILABLE BLOCK
%INTEGER DIV                           ;! CURRENT DIVISOR               00003050
%INTEGER I                             ;! LOOP VARIABLE
%INTEGER IND                           ;! ACTION INDICATOR
%INTEGER J                             ;! LOOP VARIABLE
%INTEGER LRECL                         ;! LENGTH OF CURRENT RECORD
%INTEGER MAXB                          ;! NO OF BLOCKS FILLED
%INTEGER MAXN                          ;! COUNT OF NO OF TITLES
%INTEGER N1                            ;! USED IN PRINTING JOURNAL      00003430
%INTEGER N2                            ;! NUMBERS WITH LEADING ZEROS    00003460
%INTEGER NL                            ;! NEW LINE SYMBOL
%INTEGER NUM                           ;! CURRENT JOURNAL NUMBER
%INTEGER ONE                           ;! CONSTANT
%INTEGER POSN                          ;! CURRENT AVAILABLE POSITION
%INTEGER STNUM                         ;! LAST JOURNAL NUMBER
%INTEGER UNIT                          ;! LUN OF MASTER JOURNAL FILE
!
%SWITCH SW(1:2)                        ;! ACTION SWITCH
!
     BLOCK=2                           ;! FIRST AVAILABLE BLOCK
     MAXN=0                            ;! ZEROISE COUNT
     NL=X'0A'                          ;! NEW LINE SYMBOL
     ONE=1                             ;! SET CONSTANT
     POSN=1                            ;! FIRST AVAILABLE POSITION
     STNUM=0                           ;! ZEROISE LAST NUMBER
     UNIT=10                           ;! SET LUN OF DISC FILE
!
!    HEADING
!
     NEWPAGE
     SPACES(8)
     PRINTSTRING('MASTER JOURNAL TITLE FILE')
     NEWLINE
     SPACES(8)
     PRINTSTRING('*************************')
     NEWLINES(2)
!
     OPENDA(UNIT)                      ;! OPEN DISC FILE
!
     READ (IND)                        ;! READ ACTION REQUIREMENT
     -> SW(IND)
!
!
!    IND=1   CREATE NEW MASTER JOURNAL FILE
!
SW(1):SELECT INPUT(6)
     SETMARGINS(6,1,88)
NEXT:GET TITLE(JREC,ONE,LRECL,NUM)    ;! READ NEW JOURNAL TITLE
     %IF NUM=0 %THEN -> END            ;! CHECK FOR END OF FILE
     NEWLINES(2)
     SPACE
     DIV=100000
     N1=NUM
     %CYCLE I=1,1,6                    ;! PRINT JOURNAL NUMBER
     N2=N1//DIV
     PRINT SYMBOL(N2!X'30')
     N1=N1-N2*DIV
     DIV=DIV//10
     %REPEAT
     SPACE
     %CYCLE I=1,1,LRECL
     PRINT SYMBOL(JREC(I))             ;! PRINT TITLE
     %REPEAT
!
!    CHECK JOURNAL NUMBER IS IN ORDER
!
     %IF NUM>STNUM %THEN -> WRBF       ;! JUMP IF STRICTLY ASCENDING
     NEWLINE
     PRINTSTRING(' ****** JOURNAL NUMBER OUT OF ORDER OR REPEATED')
     PRINTSTRING(' - RECORD IGNORED')
     -> NEXT                          ;! FETCH NEXT RECORD
!
!    ADD THIS RECORD TO THE DISC BUFFER, WRITING THE LATTER TO DISC
!    AS BECOMES NECESSARY.
!
WRBF:STNUM=NUM                         ;! STORE NEW JOURNAL NUMBER
     %IF POSN+LRECL+1 > MXBUFS %THENC
         %START                        ;! WRITE BLOCK IF INSUFF ROOM
         WRITEDA(UNIT,BLOCK,BUFFER(1),BUFFER(MXBUFS))
         BLOCK=BLOCK+1                 ;! RESET BLOCK AND POSITION
         POSN=1                        ;! POINTERS
         %FINISH
     BUFFER(POSN)=LRECL>>8&X'FF'       ;! STORE RECORD LENGTH
     BUFFER(POSN+1)<-LRECL             ;! IN FIRST TWO BYTES
     %CYCLE I=1,1,LRECL
     BUFFER(POSN+I+1)=JREC(I)          ;! MOVE TITLE TO BUFFER AREA
     %REPEAT
     MAXN=MAXN+1                       ;! INCREMENT COUNT
     MJNUMB(MAXN)=NUM                  ;! STORE JOURNAL NUMBER
     MJBPTR(MAXN)=BLOCK                ;! STORE BLOCK AND
     MJPPTR(MAXN)=POSN                 ;! POSITION POINTERS
     POSN=POSN+LRECL+2                 ;! UPDATE POSITION POINTER
     %IF MAXN<MXNUMB %THEN -> NEXT    ;! FETCH NEXT IF < LIMIT
     NEWLINES(3)                       ;! MESSAGE IF LIMIT EXCEEDED
     PRINTSTRING(' ****** ')
   PRINTSTRING('MAXIMUM NUMBER OF JOURNALS REACHED - NO MORE ACCEPTED')
!
!    INPUT COMPLETED - LAST BLOCK AND CONTROL DATA WRITTEN TO DISC
!
END: WRITEDA(UNIT,BLOCK,BUFFER(1),BUFFER(MXBUFS))
     CNT(1)=MAXN                       ;! STORE NUMBER OF RECORDS
     CNT(2)=BLOCK                      ;! STORE NEXT AVAILABLE BLOCK
     CNT(3)=POSN                       ;! STORE NEXT AVAILABLE POSITION
!
     BLOCK=BLOCK+1                     ;! WRITE JOURNAL NUMBERS
     CNT(4)=BLOCK
     WRITEDA(UNIT,BLOCK,MJNUMB(1),MJNUMB(MAXN))
     BLOCK=BLOCK+1                     ;! WRITE POSITION POINTERS
     CNT(5)=BLOCK
     WRITEDA(UNIT,BLOCK,MJBPTR(1),MJBPTR(MAXN))
     BLOCK=BLOCK+1                     ;! WRITE BLOCK POINTERS
     CNT(6)=BLOCK
     WRITEDA(UNIT,BLOCK,MJPPTR(1),MJPPTR(MAXN))
     MAXB=BLOCK                        ;! STORE MAXIMUM
     WRITEDA(UNIT,ONE,CNT(1),CNT(6))   ;! WRITE CONTROL BLOCK
     CLOSEDA(UNIT)                     ;! CLOSE FILE
!
!    TERMINATION MESSAGES
!
     NEWLINES(4)                                                        00012300
     SPACES(8)
     PRINTSTRING('MASTER JOURNAL FILE CREATED')
     NEWLINE
     -> ENDR
!
!    IND=2   READ MASTER JOURNAL FILE FROM DISC AND PRINT
!
SW(2):BLOCK=1                          ;! READ CONTROL BLOCK
     READDA(UNIT,BLOCK,CNT(1),CNT(6))
     MAXN=CNT(1)                       ;! SET MAXIMUM NUMBER OF RECS
     BLOCK=CNT(4)                      ;! READ JOURNAL NUMBERS
     READDA(UNIT,BLOCK,MJNUMB(1),MJNUMB(MAXN))
     BLOCK=CNT(5)                      ;! READ BLOCK POINTERS
     READDA(UNIT,BLOCK,MJBPTR(1),MJBPTR(MAXN))
     BLOCK=CNT(6)                      ;! READ POSITION POINTERS
     READDA(UNIT,BLOCK,MJPPTR(1),MJPPTR(MAXN))
     MAXB=BLOCK                        ;! STORE MAXIMUM
!
!    LOOP THROUGH ARRAY PRINTING DETAILS
!
     %CYCLE I=1,1,MAXN
     NEWLINES(2)
     SPACE
     DIV=100000                        ;! EXTRACT DIGITS OF NUMBER
     N1=MJNUMB(I)
     %CYCLE J=1,1,6
     N2=N1//DIV
     PRINT SYMBOL(N2!X'30')
     N1=N1-N2*DIV
     DIV=DIV//10
     %REPEAT
     SPACE
     %IF BLOCK\=MJBPTR(I) %THENC
         %START                        ;! READ NEW BLOCK IF NECESSARY
         BLOCK=MJBPTR(I)
         READDA(UNIT,BLOCK,BUFFER(1),BUFFER(MXBUFS))
         %FINISH
     POSN=MJPPTR(I)                    ;! SET START OF RECORD
     LRECL=BUFFER(POSN)<<8!BUFFER(POSN+1)
     POSN=POSN+1                       ;! EXTRACT LENGTH, INCREMENT PTR
     %CYCLE J=1,1,LRECL
     PRINT SYMBOL(BUFFER(POSN+J))      ;! PRINT TITLE
     %REPEAT
     %REPEAT
     CLOSEDA(UNIT)
!
     NEWLINES(4)
ENDR:SPACES(8)
     PRINTSTRING('TOTAL NUMBER OF JOURNALS =')
     WRITE (CNT(1),3)
     NEWLINE
     SPACES(8)
     PRINTSTRING('TOTAL NUMBER OF BLOCKS OCCUPIED =')
     WRITE(MAXB,3)
     NEWLINES(2)
     SPACES(8)
     PRINTSTRING('*** JOB TERMINATED ***')
     %STOP
!
! *********************************************************************
!
     %ROUTINE GET TITLE (%BYTEINTEGERARRAYNAME JNTITL                %C
                         %INTEGERNAME JST,JLNG,JNUM)
!
!    ROUTINE FETCHES THE NEXT VALID JOURNAL TITLE FROM THE INPUT
!    STREAM.   THE NUMBER IS RETURNED IN JNUM WHILE THE TEXT OF THE
!    TITLE IS STORED IN JNTITL STARTING AT JST AND OF LENGTH JLNG.
!
!    THE INPUT RECORDS MUST BE IN THE FORMAT SPECIFIED .....
!
!    NNNNNN-S TEXT OF THE TITLE         . . . .          C
!
!    NNNNNN   THE 6-DIGIT JOURNAL NUMBER INC THE CHECK DIGIT
!
!    S        THE SEQUENCE NUMBER.   TO ENSURE THE TEXT OF A TITLE
!             DOES NOT GET OUT OF ORDER EACH 'CARD' FORMING PART OF
!             A TITLE CARRIES A SEQUENCE NUMBER BETWEEN 1 AND 9
!
!    C        WHERE A TITLE REQUIRES MORE THAN ONE 'CARD' ALL 'CARDS'
!             EXCEPT THE LAST MUST HAVE THE CHARACTER 'C' IN THE 73RD   00015900
!             CHARACTER POSITION AS A CONTINUATION SYMBOL.
!
%EXTERNALROUTINESPEC ISOCARD (%BYTEINTEGERARRAYNAME A)
%INTEGERFNSPEC CONV (%BYTEINTEGERARRAYNAME A,%INTEGER IA,L)
!
%BYTEINTEGERARRAY BUF(1:80)            ;! INPUT BUFFER AREA
%INTEGER SUM                           ;! USED TO CALCULATE CHECK DIGIT
%INTEGER CD                            ;! CHECK DIGIT
%INTEGER I                             ;! LOOP VARIABLE
%INTEGER JS                            ;! CURRENT START VALUE OF J
%INTEGER J                             ;! POINTER TO TITLE ARRAY
%INTEGER LIM                           ;! PRINT LOOP LIMIT
%INTEGER ST                            ;! PRINT LOOP START POINT
%INTEGER RNO                           ;! SWITCH VARIABLE (RET(RNO))
%BYTEINTEGER CHAR                      ;! CURRENT CHARACTER
%BYTEINTEGER CASE                      ;! CURRENT CASE (SHIFT OR NORMAL)
%BYTEINTEGER SEQNO                     ;! SEQUENCE NUMBER
!
%SWITCH ERR(1:6)                       ;! ERROR SWITCH
%SWITCH RET(1:3)                       ;! RETURN SWITCH FROM PRINT
!
!    ON ENTRY TO THE ROUTINE THE NEXT CARD IMAGE IS READ IN
!
RDCD:ISOCARD(BUF)                      ;! READ I/P RECORD
     %IF BUF(1)='E' %THENC
         %START                        ;! END OF FILE FOUND
         JNUM=0                        ;! SET ZERO AS EOF INDICATOR
         %RETURN                       ;! RETURN TO CALLING ROUTINE
         %FINISH
!
!    CALCULATE CHECK DIGIT
!
CHCD:SUM=0                             ;! INITIALISE SUM
     %CYCLE I=1,1,5
     SUM=SUM+(7-I)*(BUF(I)&X'0F')      ;! ADD WEIGHTED VALUES
     %REPEAT
     CD=10-(SUM-SUM//11*11)            ;! CALC SINGLE CHECK DIGIT
     %IF CD=10 %THEN CD=0              ;! AND COMPARE WITH THAT GIVEN
     %IF BUF(6)\=CD!X'30' %THEN -> ERR(1)
!
!    VALID JOURNAL NUMBER
!
     JNUM=CONV(BUF,1,6)                ;! CONVERT TO BINARY
     SEQNO='0'                         ;! INITIALISE SEQUENCE NUMBER
     CASE=X'20'                        ;! INITIALISE CASE TO SHIFT
     JS=JST                            ;! INITIALISE STARTING POINT
!
!    CHECK SEQUENCING - IGNORING IF INVALID
!
CHSQ:%IF BUF(8)\=SEQNO+1 %THEN -> ERR(2)
     SEQNO=BUF(8)                      ;! STORE NEW SEQUENCE NUMBER
!
!    INPUT DATA IS O.K. AND IS ADDED TO THE CURRENT TITLE
!
     J=JS-1                            ;! SET START VALUE OF POINTER
     %CYCLE I=10,1,72                  ;! CYCLE THROUGH I/P REC         00021500
     CHAR=BUF(I)                       ;! EXAMINE NEXT CHARACTER
     %IF CHAR='<' %OR CHAR='>' %THENC
         %START                        ;! CASE CHANGE - SET NEW CASE
         %IF CHAR='<' %THEN CASE=0 %ELSE CASE=X'20'
         -> REPT                       ;! CONTINUE
         %FINISH
     J=J+1                             ;! UPDATE TITLE POINTER
     JNTITL(J)=CHAR!CASE               ;! AND STORE CHARACTER
REPT:%REPEAT
!
!    WHEN THE END OF THIS I/P RECORD IS REACHED TRAILING BLANKS ARE
!    REMOVED.   A SINGLE SPACE IS LEFT IF A CONTINUATION IS EXPECTED
!
CHKJ:%IF JNTITL(J)=' ' %THENC
         %START                        ;! BLANK CHARACTER
         J=J-1                         ;! DECREMENT THE POINTER
         %IF J>JS %THEN -> CHKJ        ;! CONTINU UNLESS START REACHED
         %IF JS=JST %THEN -> ERR(3)    ;! ERROR - 1ST TITLE CARD BLANK
         -> ERR(4)                     ;! ERROR - BLANK CARD IN TITLE
         %FINISH
!
!    CHECK FOR A CONTINUATION CARD
!
     %IF BUF(73)\='C' %THENC
         %START                        ;! END OF TITLE REACHED
         JLNG=J-JST+1                  ;! CALC LENGTH OF TITLE
         %RETURN                       ;! RETURN TO CALLING ROUTINE
         %FINISH
     JNTITL(J+1)=' '                   ;! ENSURE SPACING CHAR IS BLANK
     JS=J+2                            ;! CONTINUATION - ALLOW A BLANK
!
!    READ CONTINUATION CARD AND CHECK THAT THE JOURNAL NUMBER AGREES
!
RDCN:ISOCARD(BUF)                      ;! READ NEXT CARD
     %IF BUF(1)='E' %THEN -> ERR(5)    ;! ERROR - END OF FILE FOUND
     %IF CONV(BUF,1,6)\=JNUM %THEN -> ERR(6) ;! ERROR - JNUM DISAGREES
     -> CHSQ                           ;! NUMBER O.K. CHECK SEQUENCING
!
!    ERROR SECTION - MESSAGES AND OFFENDING RECORDS ARE PRINTED AND
!    PROCESSING CONTINUES AS SUTABLE THEREAFTER.
!
ERR(1):NEWLINES(2)                     ;! CHECK DIGIT WRONG
     PRINTSTRING(' ****** INVALID CHECK DIGIT - RECORD IGNORED')
     -> RET(1)                         ;! JUMP TO PRINT RECORD
!
ERR(2):NEWLINES(2)                     ;! TITLE CARDS OUT OF ORDER
   PRINTSTRING(' ****** SEQUENCE NUMBER OUT OF ORDER - RECORD IGNORED')
     %IF SEQNO='0' %THEN -> RET(1)
     RNO=1                             ;! JUMP TO PRINT RECORD
     -> PREC
!
ERR(3):NEWLINES(2)                     ;! WARNING MESSAGE
     PRINTSTRING(' ****** BLANK CARD IN DATA - IGNORED')
     -> RDCD                           ;! READ NEXT RECORD
!
ERR(4):NEWLINES(2)                     ;! WARNING MESSAGE
     PRINTSTRING(' ****** BLANK CARD IN RECORD - IGNORED')
     -> RDCN                           ;! READ REST OF CURRENT RECORD
!
ERR(5):NEWLINES(2)                     ;! END OF FILE FOUND UNEXPECTEDLY
     PRINTSTRING(' ****** END OF DATA FOUND IN MIDDLE OF RECORD')
     PRINTSTRING(' - RECORD IGNORED')
     RNO=2                             ;! PRINT RECORD DETAILS
     -> PREC
RET(2):JNUM=0                          ;! SET EOF INDICATOR
     %RETURN                           ;! RETURN TO CALLING ROUTINE
!
ERR(6):NEWLINES(2)                     ;! JOURNAL NUMBER CHANGES
     PRINTSTRING(' ****** JOURNAL NUMBER CHANGES IN MIDDLE OF RECORD')
     PRINTSTRING(' - RECORD IGNORED')
     RNO=3                             ;! JUMP TO PRINT RECORD
     -> PREC
RET(3):%IF BUF(8)='1' %THEN -> CHCD    ;! IF START OF NEW TITLE CONT
     NEWLINE                           ;! ELSE IGNORE 2ND REC TOO
     PRINTSTRING(' ****** NEW RECORD NOT IN ORDER - ALSO IGNORED')
     -> RET(1)
!
!
!    THIS SECTION PRINTS THE I/P RECORDS THAT HAVE NOT BEEN
!    TRANSFERRED TO THE TITLE ARRAY AND ARE TO BE IGNORED.
!
RET(1):NEWLINE
     PRINTSTRING(' ****** ')
     %CYCLE I=1,1,80
     PRINT SYMBOL(BUF(I))
     %REPEAT
     %IF BUF(73)='C' %THENC                                             00030200
         %START                        ;! READ ALL CONTINUATION CARDS
         ISOCARD(BUF)
         -> RET(1)                     ;! AND PRINT THEM FOR REFERENCE
         %FINISH
     -> RDCD                           ;! READ NEXT TITLE
!
!    THIS SECTION PRINTS THE RECORD OR PART THEREOF THAT IS ALREADY
!    IN THE ARRAY JNTITL.
!
PREC:LIM=J                             ;! INITIALISE LIMIT
     ST=1                              ;! INITIALISE START
NLIN:NEWLINE
     PRINTSTRING(' ****** ')
     %IF LIM>80 %THENC
         %START                        ;! LINES OF 80 CHARS ARE PRINTED
         %CYCLE I=ST,1,ST+79
         PRINT SYMBOL(JNTITL(I))
         %REPEAT
         LIM=LIM-80                    ;! DECREMENT LIMIT
         ST=ST+80                      ;! UPDATE START POINT
         -> NLIN                       ;! PRINT NEXT LINE
         %FINISH
     %CYCLE I=ST,1,ST+LIM-1
     PRINT SYMBOL(JNTITL(I))           ;! PRINT LAST LINE
     %REPEAT
     -> RET(RNO)                       ;! EXIT AS APPROPRIATE
!
!
! *********************************************************************
!
     %INTEGERFN CONV(%BYTEINTEGERARRAYNAME A,%INTEGER IA,L)
!
!    FUNCTION CALCULATES THE INTEGER VALUE OF THE L DIGITS IN THE
!    ARRAY A STARTING AT A(IA).
!
     %INTEGER SUM,I
!
         SUM=0
         %CYCLE I=0,1,L-1
         SUM = 10*SUM+(A(IA+I)&X'0F')
         %REPEAT
         %RESULT=SUM
     %END;! CONV
     %END ;! GET TITLE
     %END
%ENDOFPROGRAM