%BEGIN
!
!    ROUTINE TO TEST CREATION OF THE CUMULATION FILE FROM LIBPIP
!
%ROUTINESPEC RDCUM(%INTEGER UNT,IND)
!
!?? SHORT; %INTEGERARRAY IRDIRC (1:32)
%BYTEINTEGERARRAY IRTEXT(1:500)
%INTEGERARRAY IDENT(1:13)
!
%INTEGER I
%INTEGER UNIT
!
     UNIT=10                           ;! SET UNIT NUMBER
!
     RDCUM(UNIT,1)
     NEWPAGE
     PRINTSTRING('CUMULATIVE FILE DETAILS')
     NEWLINE
     PRINTSTRING('***********************')
     NEWLINES(2)
     PRINTSTRING('IDENTIFIER - ')
     %CYCLE I=0,1,31
     PRINT SYMBOL(BYTEINTEGER(ADDR(IDENT(1))+I))
     %REPEAT
     WRITE(IDENT(9),6)
     PRINTSTRING(' -')
     WRITE(IDENT(10),10)
     NEWLINES(2)
!
RD:  RDCUM(UNIT,2)
     %IF IRDIRC(1)=9999 %THEN -> END
     NEWLINES(2)
     %CYCLE I=1,2,IRDIRC(1)-1
     WRITE(IRDIRC(I),3)
     WRITE(IRDIRC(I+1),3)
     PRINTSTRING(' //')
     %REPEAT
     NEWLINE
     %CYCLE I=1,1,IRDIRC(2)
     %IF IRTEXT(I)<' ' %THEN WRITE(IRTEXT(I),2) %ELSEC
     PRINT SYMBOL(IRTEXT(I))
     %REPEAT
     -> RD
!
END: RDCUM(UNIT,3)
     %STOP
!
! *********************************************************************
!
%ROUTINE RDCUM (%INTEGER UNIT,IND)
!
!    THIS ROUTINE READS FROM THE CUMULATIVE FILE AS FOLLOWS: -
!    IND=1  OPENS THE FILE AND READS THE CONTROL BLOCK INTO AN INTEGER
!           ARRAY IDENT OF MINIMUM LENGTH 13 WDS.
!    IND=2  READS THE NEXT RECORD FROM THE FILE INTO THE ARRAYS IRDIRC
!           AND IRTEXT (AS SPECIFIED FOR THE INTERNAL RECORD)
!    IND=3  CLOSES THE FILE.
!
%EXTERNALROUTINESPEC OPENDA  (%INTEGER CHANNEL)
%EXTERNALROUTINESPEC CLOSEDA (%INTEGER CHANNEL)
%EXTERNALROUTINESPEC READDA  (%INTEGER CHANNEL, %INTEGERNAME SECT,   %C
                              %NAME BEGIN,END)
!
%OWNBYTEINTEGERARRAY BUF(1:1000)
!
%INTEGER I
%OWNINTEGER BL=1
%OWNINTEGER MXBUFS=1000
%OWNINTEGER PS=1
!
%SWITCH ENTRY(1:3)
!
     -> ENTRY(IND)
!
ENTRY(1):OPENDA(UNIT)
     READDA(UNIT,BL,IDENT(1),IDENT(13))
     BL=BL+1                           ;! FILL BUFFER
     READDA(UNIT,BL,BUF(1),BUF(MXBUFS))
     %RETURN
!
ENTRY(2):%IF PS>MXBUFS %OR INTEGER(ADDR(BUF(PS)))=0 %THENC
         %START ;      !?? ^ WAS SHORTINTEGER
         BL=BL+1                       ;! READ NEXT BLOCK
         READDA(UNIT,BL,BUF(1),BUF(MXBUFS))
         PS=1                          ;! RESET BUFFER POINTER
         %FINISH
     IRDIRC(1)=INTEGER(ADDR(BUF(PS)));      !?? WAS SHORTINTEGER
     %IF IRDIRC(1)=9999 %THEN %RETURN  ;! CHECK FOR END OF FILE
     PS=PS+2                           ;! UPDATE POINTER
     %CYCLE I=2,1,IRDIRC(1)
     IRDIRC(I)=INTEGER(ADDR(BUF(PS)));      !?? WAS SHORTINTEGER
     PS=PS+2                           ;! TRANSFER DIRC OF RECORD
     %REPEAT
     %CYCLE I=1,1,IRDIRC(2)
     IRTEXT(I)=BUF(PS)                 ;! TRANSFER TEXT OF RECORD
     PS=PS+1
     %REPEAT
     %RETURN
!
ENTRY(3):CLOSEDA(UNIT)
!
     %END ;! RDCUM
!
%ENDOFPROGRAM