%BEGIN
!
!    ROUTINE TO TEST THE ROUTINE RDBUL AND THE CONCORDED FILE CREATED
!    BY THE BULLETIN OUTPUT ROUTINE WRBUL.
!
%ROUTINESPEC RDBUL (%INTEGERNAME UNIT,BLOCK,POSN,NO)
!
%INTEGERARRAY NUMBER (1:200)                     ;! JOURNAL NOS
!?? SHORT; %INTEGERARRAY CONC1,CONC2,CONC3(1:500) ;! CONCORDANCE ARRAYS
!?? SHORT; %INTEGERARRAY POINTF,POINTL(1:200)    ;! PTRS TO CONCORDANCE
!?? SHORT; %INTEGERARRAY IRDIRC (1:32)                 ;! REC DIRECTORY
%BYTEINTEGERARRAY IRTEXT (1:500)                 ;! RECORD TEXT
!
%INTEGER BLOCK                         ;! BLOCK CONTAINING REC
%INTEGER CHECK
%INTEGER I                             ;! LOOP VARIABLE
%INTEGER IC                            ;! CONCORDANCE POINTER
%INTEGER IND                           ;! RDBUL ENTRY NUMBER
%INTEGER J                             ;! LOOP VARIABLE
%INTEGER MAXC                          ;! NO OF ITEMS IN CONCORDANCE
%INTEGER MAXN                          ;! NO OF DIFFERENT JOURN NOS
%INTEGER MXBUFB
%INTEGER MXCNTB
%INTEGER MXDIRC
%INTEGER N1
%INTEGER N2
%INTEGER POSN                          ;! POSN OF REC IN BLOCK
%INTEGER UNIT                          ;! UNIT CONTAINING BUL FILE
%INTEGER WEEKNO
%INTEGER YES
!
     CHECK=0
     YES=1
     WEEKNO=140
     MXDIRC=32
     MXBUFB=1000                                                        00003400
     MXCNTB=500                                                         00003500
     UNIT=10                           ;! SET UNIT NUMBER
     IND=1                             ;! SET INDIC FOR FIRST CALL
!
     RDBUL(UNIT,BLOCK,POSN,IND)        ;! OPEN FILE
     IND=2                             ;! CHANGE IND FOR NORMAL READ
     MAXC=0                            ;! ZEROISE MAX CONC PTR
!
     NEWPAGE
     PRINTSTRING('BULLETIN FILE DETAILS')
     NEWLINE
     PRINTSTRING('*********************')
     NEWLINES(2)
     PRINTSTRING('CONTROL BLOCK DETAILS')
     NEWLINES(2)
     PRINTSTRING(' JOURNAL    1ST CONC LAST CONC')
     NEWLINE
     %CYCLE I=1,1,MAXN
     NEWLINE
     PRINT SYMBOL(NUMBER(I)>>24&X'FF') ;! PRINT JOURNAL NUMBER
     N1=NUMBER(I)&X'FFFFFF'
     %CYCLE J=0,1,6
     N2=N1//INT(10**(6-J));       !?? INT INSERTED
     PRINT SYMBOL(N2!X'30')
     N1=N1-N2*INT(10**(6-J));      !?? INT INSERTED
     %REPEAT
     WRITE(POINTF(I),8)                ;! PRINT PTR TO  1ST CONC
     WRITE(POINTL(I),9)                ;! PRINT PTR TO LAST CONC
     %IF POINTL(I)>MAXC %THEN MAXC=POINTL(I)     ;! UPDATE MAXC IF NEC
     %REPEAT
!
     NEWLINES(2)
     PRINTSTRING('     BLOCK  POSITN  NEXT CONC')
     NEWLINE
!
     %CYCLE I=1,1,MAXC
     NEWLINE
     WRITE(I,3)                        ;! PRINT CONC NUMBER
     WRITE(CONC1(I),4)                 ;! BLOCK NUMBER
     WRITE(CONC2(I),6)                 ;! POSN IN BLOCK
     WRITE(CONC3(I),9)                 ;! NEXT CONCORDANCE
     %REPEAT
!
     NEWLINES(2)
     %CYCLE I=1,1,MAXN                 ;! PRINT RECORD DETAILS
     NEWLINES(3)
     PRINT SYMBOL(BYTEINTEGER(ADDR(NUMBER(I))))
     N1=NUMBER(I)&X'FFFFFF'
     %CYCLE J=0,1,6
     N2=N1//INT(10**(6-J));      !?? INT INSERTED
     PRINT SYMBOL(N2!X'30')
     N1=N1-N2*INT(10**(6-J));      !?? INT INSERTED
     %REPEAT
     NEWLINE
     PRINTSTRING('........')
!
     IC=POINTF(I)                      ;! SET 1ST VALUE OF CONC PTR
L2:  BLOCK=CONC1(IC)                   ;! EXTRACT BLOCK NUMBER
     POSN =CONC2(IC)                   ;! EXTRACT START POSN IN BLOCK
     RDBUL(UNIT,BLOCK,POSN,IND)        ;! READ THIS RECORD
     NEWLINES(2)
     %CYCLE J=1,2,IRDIRC(1)-1          ;! PRINT DIRECTORY
     WRITE (IRDIRC(J),3)
     WRITE (IRDIRC(J+1),3)
     PRINTSTRING(' //')
     %REPEAT
!
     NEWLINE
     %CYCLE J=1,1,IRDIRC(2)            ;! PRINT TEXT
     %IF IRTEXT(J)<' ' %THEN WRITE(IRTEXT(J),2) %ELSEC
     PRINT SYMBOL(IRTEXT(J))
     %REPEAT
!
     IC=CONC3(IC)                      ;! EXTRACT NEXT VALUE OF IC
     %IF IC\=0 %THEN -> L2             ;! CONTINUE IF NON-ZERO
     %REPEAT
!
     NEWLINES(2)
     PRINTSTRING('ALL RECORDS NOW PRINTED')
     IND=3
     RDBUL(UNIT,BLOCK,POSN,IND)        ;! CLOSE FILE
!
! *********************************************************************
!
     %ROUTINE RDBUL (%INTEGERNAME UNIT,BLOCK,POSN,NO)
!
!    THE ROUTINE HAS EFFECTIVELY THREE ENTRYPOINTS DEPENDING ON THE
!    VALUE OF NO WHICH MAY BE 1,2 OR 3.
!
!    NO=1   FIRST ENTRY - THE DISC FILE (UNIT) IS OPENED AND THE CONTROL
!        BLOCK READ.   THE APPROPRIATE BLOCKS ARE THEN READ IN AND THE
!        POINTER TABLES SET UP.   CONTROL IS THEN RETURNED.
!
!    NO=2   NORMAL ENTRY - THE RECORD COMMENCING AT BYTE (POSN) IN
!        SECTOR (BLOCK) IS READ FROM THE DISC FILE AND TRANSFERRED
!        TO THE DIRECTORY AND TEXT ARRAYS.
!
!    NO=3   WHEN PROCESSING IS COMPLETE THE PROGRAM MUST CALL RDBUL
!        WITH NO=3 TO CLOSE THE DISC FILE.
!
     %EXTERNALROUTINESPEC OPENDA (%INTEGER CHANNEL)
     %EXTERNALROUTINESPEC CLOSEDA(%INTEGER CHANNEL)
     %EXTERNALROUTINESPEC  READDA (%INTEGER CHANNEL,                 %C
                                   %INTEGERNAME SECT,                %C
                                   %NAME BEGIN,END)
!
     %OWNBYTEINTEGERARRAY BUF(1:1000)  ;! INPUT BUFFER                  00013100
     !?? SHORT; %INTEGERARRAY CNTBUF(1:500)  ;! CONTROL AREA BUFFER
     !??                                               00013200
!
     %SWITCH ENTRY(1:3)                ;! ENTRYPOINT SWITCH
     %OWNINTEGER SECT                  ;! SECTOR CURRENTLY IN BUFFER
!
     %INTEGER I,J,K                    ;! LOOP VARIABLES
     %INTEGER IN,IC,NSEC,CSEC          ;! CONTROL BLOCK VARIABLES
     %INTEGER IB                       ;! BUFFER POINTER
!
!    JUMP TO APPROPRIATE ENTRY POINT
!
     -> ENTRY(NO)
!
!    FIRST ENTRY - OPEN FILE, CHECK WEEK NUMBER IF REQUIRED
!    AND SET UP THE CONTROL TABLES.
!
ENTRY(1):OPENDA(UNIT)                  ;! OPEN FILE
     SECT=1                            ;! READ CONTROL BLOCK
     READDA(UNIT,SECT,CNTBUF(1),CNTBUF(MXCNTB))
     %IF CHECK=YES %THENC
         %START                        ;! CHECK WEEK NUMBER
         %IF WEEKNO\=CNTBUF(1) %THENC
             %START                    ;! WEEK NUMBER FAILS TO AGREE
             NEWLINE                   ;! PRINT MESSAGE
             PRINTSTRING('WEEK NUMBERS DO NOT AGREE')
             NEWLINE
             PRINTSTRING('WEEK')          ;! PRINT DETAILS
             WRITE(WEEKNO,3)
             PRINTSTRING(' REQUESTED')
             NEWLINE
             PRINTSTRING('WEEK')
             WRITE(CNTBUF(1),3)
             PRINTSTRING(' IN THIS FILE')
             NEWLINES(2)               ;! TERMINATE JOB
             PRINTSTRING('*** JOB TERMINATED ***')
             %STOP
             %FINISH
         %FINISH %ELSEC
         WEEKNO=CNTBUF(1)              ;! SET WEEK NUMBER
!
!    SET CONTROL VARIABLES FROM CONTROL BLOCK.
!
     IN=CNTBUF(2)                      ;! LENGTH OF POINTER TABLE
     NSEC=CNTBUF(3)                    ;! START SECTOR OF TABLES
     IC=CNTBUF(4)                      ;! LENGTH OF CONCORDANCE
     CSEC=CNTBUF(5)                    ;! START SECTOR OF CONCORDANCES
!
!    READ POINTER TABLES FROM DISC - THEY MAY BE IN ONE SECTOR OR
!    SEVERAL DEPENDING ON THE TOTAL NUMBER OF DIFFERENT JOURNALS.
!
     %IF 8*IN<=MXBUFB %THENC
         %START                        ;! POINTERS IN SINGLE SECTOR
         READDA(UNIT,NSEC,CNTBUF(1),CNTBUF(MXCNTB))
         J=IN+IN                       ;! START OF POINTER 1
         K=J+IN                        ;! START OF POINTER 2
         %CYCLE I=1,1,IN
         NUMBER(I)=INTEGER(ADDR(CNTBUF(I+I-1)))
         POINTF(I)=CNTBUF(J+I)
         POINTL(I)=CNTBUF(K+I)
         %REPEAT
         %FINISH %ELSEC
         %START                        ;! POINTERS IN SEVERAL SECTORS
         READDA(UNIT,NSEC,NUMBER(1),NUMBER(IN))
         NSEC=NSEC+1
         READDA(UNIT,NSEC,POINTF(1),POINTF(IN))
         NSEC=NSEC+1
         READDA(UNIT,NSEC,POINTL(1),POINTL(IN))
         %FINISH
!
!    SET MAXIMUM NUMBER OF JOURNALS AND READ CONCORDANCE ARRAYS
!
     MAXN=IN
     READDA(UNIT,CSEC,CONC1(1),CONC1(IC))
     CSEC=CSEC+1
     READDA(UNIT,CSEC,CONC2(1),CONC2(IC))
     CSEC=CSEC+1
     READDA(UNIT,CSEC,CONC3(1),CONC3(IC))
     %RETURN
!
!    NORMAL ENTRY - THE BLOCK NUMBER REQUESTED IS CHECKED AGAINST THE
!    NUMBER OF THE SECTOR CURRENTLY IN THE BUFFER TO AVOID UNNECESSARY
!    READING FROM THE DISC.
!
ENTRY(2):%IF BLOCK\=SECT %THENC
         %START                        ;! DISC READ NECESSARY
         SECT=BLOCK                    ;! SET SECTOR NUMBER
         READDA(UNIT,SECT,BUF(1),BUF(MXBUFB))
         %FINISH
!
!    TRANSFER DATA FROM THE BUFFER TO THE INTERNAL RECORD.
!
     IB=POSN                           ;! SET BUFFER POINTER
!
DIRC:%CYCLE I=1,1,MXDIRC               ;! TRANSFER DIRECTORY SECTION
     IRDIRC(I)=INTEGER(ADDR(BUF(IB)));      !?? WAS SHORTINTEGER
     IB=IB+2                           ;! UPDATE BUFFER POINTER
     %IF IB>MXBUFB %THENC
         %START                        ;! END OF BUFFER REACHED
         SECT=SECT+1                   ;! UPDATE CURRENT SECTOR NUMBER
         READDA(UNIT,SECT,BUF(1),BUF(MXBUFB))
         IB=1                          ;! RESET BUFFER POINTER
         %FINISH
     %REPEAT
!
TEXT:%CYCLE I=1,1,IRDIRC(2)            ;! TRANSFER TO TEXT ARRAY
     IRTEXT(I)=BUF(IB)
     IB=IB+1                           ;! UPDATE BUFFER POINTER
     %IF IB>MXBUFB %THENC
         %START                        ;! END OF BUFFER REACHED
         SECT=SECT+1                   ;! UPDATE CURRENT SECTOR NUMBER
         READDA(UNIT,SECT,BUF(1),BUF(MXBUFB))
         IB=1                          ;! RESET BUFFER POINTER
         %FINISH
     %REPEAT
!
     %RETURN
!
!    THE LAST ENTRY CLOSES THE FILE
ENTRY(3):CLOSEDA(UNIT)
     %END ;! RDBUL
%ENDOFPROGRAM