SPL,L,O 
!     NAME:   LI..
!     SOURCE: 92067-18221 
!     RELOC:  92067-16185 
!     PGMR:   G.A.A.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
!  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
!  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
!  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
!  ***************************************************************
! 
      NAME LI..(8) "92067-16185 REV.2001 791023"
! 
!  MODIFICATION RECORD: 
! 
!      DATE    REASON 
!  1) 780531   TO USE NEW FSTAT FOR 256-WORD CARTRIDGE DIRECTORY
!  2) 780630   TO PRINT FILE SIZE IN BLKS OR BLK MULTIPLES
!  3) 780919   TO USE EXTENDED FMP CALL (ELOCF) 
!  4) 780919   TO CHECK FOR REC #'S > 32767 & WRAP AROUND 
!  5) 790127   TO PRINT ASCII CRNS AS 2 ASCII CHARACTERS
!  6) 791023   TO REPORT ERROR IF 1ST REQUESTED RECORD >
!              #RECORDS IN FILE (SST #4629), AND TO SKIP TO 
!              1ST RECORD USING READF FOR TYPE 1 AND 2 FILES
! 
!     LI.. IS THE RTE FMGR FILE LIST MODULE 
!          IT IS ENTERED ON COMMAND 
! 
!     LI,NAMR,TY
! 
!        WHERE: 
! 
! 
!         NAMR    IS THE NAME REFERENCE INCLUDING 
!                 SECURITY CODE AND DISC ID 
! 
!         TY     IS THE LISTING TYPE AND IS ASCII:
! 
!             S OR A OR NULL SOURCE WITH LINE NUMBERS 
!             B              BINARY DUMP
!             D              DIRECTORY HEAD ONLY
! 
! 
!     EACH LISTING WILL BE PRECEEDED BY THE HEAD: 
! 
!      NAMEL T=XXXXX IS ON CRXXXXX USING XXXX BLKS R=XXXX 
! 
! 
! 
! 
! 
!     S FORMAT IS A BLANK FOLLOWED BY 4 DIGIT 
!        LINE NUMBER FOLLOWED BY TWO BLANKS FOLLOWED
!       BY THE RECORD.
! 
!     B FORMAT IS : 
!       A)THE RECORD HEAD: REC# XXXXX 
!       B)N LINES FORMATED AS FOLLOWS 
!         8 5-DIGIT OCTAL NUMBERS SEPARATED BY BLANKS 
!           AND FOLLOWED BY A "*" FOLLOWED BY THE 
!           16 ASCII CHARACTERS THE DIGITS REP. 
!            NON-PRINTING CHARACTERS WILL BE FILLED 
!            WITH BLANKS
! 
!     D FORMAT IS THE HEAD ONLY 
! 
! 
! 
!     DEFINE EXTERNALS
! 
      LET .TTY,                    \DETERMINE IF INTERACTIVE
          NAM..                    \NAME CHECKING ROUTINE 
             BE FUNCTION,EXTERNAL 
! 
      LET JER.                     \FMGR ERROR HANDLING ROUTINE 
             BE SUBROUTINE,EXTERNAL,DIRECT
! 
      LET .E.R.,                   \FMGR ERROR WORD 
          BUF.,                    \INTERNAL FMGR BUFFER
          I.BUF,                   \INTERNAL FMGR BUFFER
          N.OPL,                   \FMGR SUBPARAMETER ARRAY 
          O.BUF,                   \INTERNAL FMGR BUFFER
          TMP.                     \LIST DEVICE 
             BE INTEGER,EXTERNAL
! 
      LET CONV.,                   \FMGR INTEGER TO ASCII CONVERSION
          ELOCF,                   \EXTENDED FMP FILE LOCATION
          EXEC,                    \RTE EXEC ROUTINE
          FSTAT,                   \FMP CARTRIDGE LIST ROUTINE
          JER.,                    \FMGR ERROR HANDLING ROUTINE 
          LOCF,                    \FMP FILE LOCATION ROUTINE 
          OPEN.,                   \FMGR OPEN ROUTINE 
          READF,                   \FMP FILE READ ROUTINE 
          WRITF                    \FMP FILE WRITE ROUTINE
             BE SUBROUTINE,EXTERNAL 
! 
!     DEFINE INTERNAL ROUTINES
! 
      LET SETA,                    \
          SPACE,                   \
          WRIT                     \
             BE SUBROUTINE,DIRECT 
! 
!     DEFINE CONSTANTS
!                                        HL 
      LET BL.T      BE CONSTANT (20124K)! T 
      LET EQ.BL     BE CONSTANT (36440K)!=
      LET BL.I      BE CONSTANT (20111K)! I 
      LET S.BL      BE CONSTANT (51440K)!S
      LET O.N       BE CONSTANT (47516K)!ON 
      LET BL.C      BE CONSTANT (20103K)! C 
      LET R.BL      BE CONSTANT (51040K)!R
      LET BL.L      BE CONSTANT (20114K)! L 
      LET U.BL      BE CONSTANT (52440K)!U
      LET BL.U      BE CONSTANT (20125K)! U 
      LET S.I       BE CONSTANT (51511K)!SI 
      LET N.G       BE CONSTANT (47107K)!NG 
      LET BL.B      BE CONSTANT (20102K)! B 
      LET L.K       BE CONSTANT (46113K)!LK 
      LET R.EQ      BE CONSTANT (51075K)!R= 
      LET A.BL      BE CONSTANT (40440K)!A
      LET B.BL      BE CONSTANT (41040K)!B
      LET D.BL      BE CONSTANT (42040K)!D
      LET R.E       BE CONSTANT (51105K)!RE 
      LET C.NO      BE CONSTANT (41443K)!C# 
      LET DST       BE CONSTANT (25052K)!** 
      LET ST.B      BE CONSTANT (25102K)!*B 
! 
!     DEFINE BUFFER SET UP
! 
      LET LSTBF(2),LNNO,BLWD,LBF(256) BE INTEGER
      LET IDM(2)                      BE INTEGER
LI..: SUBROUTINE(NOC,LIS ,ER) GLOBAL
! 
      OPFL_401K   !SET DEFAULT OPEN  OPTION 
      NUL,WRAP_0    !PRESET NULL PRAM FLAG, WRAP-AROUND FLAG
      LR_$([FR_[TYPF_[LIS1_@LIS +1]+4]+4]+4)!SET ADDRESSES
      TYPF_($TYPF AND 177400K)+40K          !GET AND ISOLATE THE TYPE 
      IF [FR_$FR] THEN[                     \SET FIRST LAST RECORD
         IFNOT  LR THEN  LR_ FR]            !DEFAULTS (1 IF ONLY FIRST) 
      IF FR<0 THEN [ER_56;RETURN]           !BAD 1ST RECORD PARM? 
      IF TYPF=A.BL THEN GO TO STYP          !CHECK FOR
      IF TYPF=40K THEN[NUL_1;GO TO STYP]    !LEGAL
      IF TYPF=D.BL THEN GO TO TYPOK         !OPTIONS
      IF TYPF=B.BL THEN[OPFL_311K;GO TO TYPOK]!NULL,A,S,B,D 
      IF TYPF#S.BL THEN [ER_56;RETURN]      !NO, BAD PARAMETER
! 
STYP: TYPF_S.BL                             !FORCE NULL,ATOS
! 
TYPOK:OPLS_ @TMP.+3                         !GET LIST UNIT OP LIST
! 
      CALL OPEN.(O.BUF,TMP.,$OPLS, 0)       !OPEN LIST FILE 
! 
      CALL OPEN.(I.BUF,$LIS1,N.OPL,OPFL)    !OPEN FILE TO BE LISTED 
! 
      CALL ELOCF(I.BUF,.E.R.,IDM,IDM,LP,IDM,FLU,FTYP,RECS)
      IFNOT NUL THEN GO TO OK !IF NULL THEN CHOSE THE RIGHT OPTION
      IFNOT FTYP THEN GO TO OK  !TYPE ZERO DEFAULT IS ASC 
      IF FTYP=3 THEN GO TO OK  !SAME FOR TYPE 3 
      IF FTYP=4 THEN GO TO OK  !SAME FOR TYPE 4 
CTYP: TYPF_B.BL      !OTHERWISE USE BINARY FORMAT 
! 
OK:   CALL LOCF(O.BUF,.E.R.,LP,LP,LP,LP,LLU) !GET LIST LU 
! 
      EXEC(13,LLU,EQT5)  !GET LIST LU TYPE CODED
! 
      P36_[P3_@LIS +4]+33  !SET UP LIST ADDRESSES 
      LP_1          !SET LINE PRINTER FLAG
      IF (EQT5 AND 37400K)<5000K THEN LP_0
      TTY_.TTY(LLU) 
      FOR T_ P3 TO P36 DO[$T_20040K] ! BLANK THE BUFFER 
      P_P3-1
      SETA(BL.T)     !SET BLANK T 
      SETA(EQ.BL)    !SET = BLANK 
      P_P+2 
      CONV.(FTYP,$P,5) !SET TYPE
      SETA(BL.I)     !SET BLANK I 
      SETA(S.BL)     !SET S BLANK 
      SETA (O.N)     !SET ON
      IF FTYP THEN[SETA(BL.C);              \IF DISC FILE FIND CR # 
                   SETA(R.BL);\ 
                   CALL FSTAT(LNNO,256,1,1);\MUST BE FOUND
                   T_@LNNO;                \SO NO STOP NEEDED 
                   UNTIL ($T AND 377K)=FLU DO T_T+4; \FIND THE LU 
                   T_$( T+2);N_5;           \SET IT UP
                   P_P+1;$P_T;              \MOVE CRN TO OUTPUT BUF 
                   IF NAM..($P)=0 THEN      \IF PASSED NAMR TEST, 
                      [P_P+1;GOTO LI1]],    \THEN SKIP CONVERSION 
       ELSE[ \
                   SETA(BL.L);              \SET UP A DIRECT LU 
                   SETA(U.BL);\ 
                   T_FLU;N_2] 
      P_P+1 
      CONV.(T,$P,N) 
LI1:  IFNOT FTYP THEN[N_13;GO TO WRHD]
      SETA(BL.U)     !SET   USING 
      SETA(S.I )
      SETA(N.G )
      P_P+3 
! 
      ADDR._@I.BUF+5                        !DCB WORD 5 (FILE SIZE) 
      IF $ADDR. < 0 THEN [                  \IF NEGATIVE, THEN
         CONV.(-($ADDR.),$P,5);             \CONVERT POSITIVE AND 
         SETA(ST.B)],                       \REPORT AS "*BLKS"
      ELSE [CONV.($ADDR./2,$P,5);           \CONVERT BLOCKS TO ASCII
            SETA(BL.B)]                     !SET BLKS R=
! 
      SETA(L.K) 
      SETA(S.BL)
      SETA(R.EQ)
! 
      P_P+2 
! 
      CONV.(RECS,$P,4)
! 
      N_27
! 
WRHD: TB_[BF_[IF TYPF=S.BL THEN @LSTBF,ELSE @BUF.]]+1 
      $BF_20040K                         !BLANK FIRST WD
      P_LIS1
      FOR T_TB TO TB+N DO [$T_$P;P_P+1] !MOVE LINE
      IF LIS #3 THEN[$([P_TB+1]+1)_DST;\IF FAKE FILE REPLACE NAME 
                        $P_DST;$TB_DST]! WITH "******"
      WRIT   !   WRITE THE HEAD 
! 
      IF TYPF=D.BL THEN GOTO EOF  !DONE IF HEAD ONLY
      SPACE                   !SPACE A LINE 
      IF FTYP=6 THEN FTYP,$(@I.BUF+2)_1 !FORCE TYPE 6 TO ONE  
      RC_1                             !DEFINE STARTING RECORD
      IF FR > 1 THEN [                 \IF SKIP REQUESTED AND 
         IF FTYP THEN [                \IF FILE IS TYPE 1 OR 2
            IF FTYP < 3 THEN RC_FR]]   !SET FIRST RECORD
NEXT: P_BF          !INITIALIZE BUFFER POINTER
      SETA(R.E)      ! SET UP 
      SETA(C.NO)     !   REC# XXXXX 
      SETA(20040K)
      P_P+2 
      CONV.(RC,$P,5)! SET NUMBER
      CALL READF(I.BUF,.E.R.,LBF,128,L,RC) ! READ RECORD
      IF .E.R.= -12 THEN [              \IF EOF 
         IF RC>FR THEN GO TO EOF]       !THEN EXIT
      JER.                         !CHECK FOR ERRORS
      IF L <0 THEN [               \SOFT EOF? 
         IF RC>FR THEN GO TO EOF,  \YES 
         ELSE [ER_ -12;RETURN]]    !NO, EOF BEFORE 1ST REQ. REC 
      IFNOT WRAP THEN                       \IF LESS THAN 32768 
         [IF RC<  FR THEN GO TO NEXTR]      !SKIP TO FIRST REQUESTED REC. 
      N_L+3 
      IF TYPF=S.BL THEN[CONV.(RC,LNNO,4);BLWD_20040K;\
                   L_0;GO TO WRTIT]!JUST LISTING - GO WRIT
! 
      SPACE         !SPACE A LINE 
      N_5           !WRITE THE RECORD NUMBER
      WRIT          ! 
      SPACE         !SPACE A LINE 
! 
      F_@LBF        !SET BUFFER POINTER 
NEXTL:IFNOT L THEN [                        \IF NO DATA GET NEXT
NEXTR:   IF RC=32767 THEN RC,WRAP_1, ELSE   \RESET RECORD COUNT 
            RC_RC+1;                        \STEP RECORD COUNT
         IF  LR THEN[                       \END OF REQUESTED DATA
            IF RC >  LR THEN GO TO EOF];    \YES GO DO EOF
         GO TO NEXT]                        !ELSE DO NEXT RECORD
      P_[ST_[WP,T_TB]+27]+1   !INITIALIZE POINTERS
      REPEAT 36 TIMES DO[ $T_20040K; T_T+1] 
      UP_ -1        !SET UPPER FLAG TRUE
      REPEAT 8 TIMES DO THRU PTSTP
      IF[T2_ [T_$F]AND 77400K]>57400K THEN GOTO BLANK 
      IF T2>17777K THEN GOTO OKUP 
! 
BLANK:T_ (T AND 177K)+20000K
! 
OKUP: IF [T2_($F AND 177K)]<140K THEN[IF  T2> 37K THEN\ 
         GO TO OKLOW] 
! 
      T_ (T AND  77400K) +40K 
! 
OKLOW:DO[ $P_T AND 77577K;P_P+1]
! 
      T2_   [T_$F-<1] AND 1 
! 
      $WP_[IF UP THEN (T2-<8)+([T_T-<3] AND 7)+30060K,\ 
                ELSE T2 + 20060K] 
! 
      REPEAT 2 TIMES DO[ \
      $[WP_WP+1]_(([T_T-<3] AND 7)-<8)+\
                  ([T_T-<3] AND 7)+ 30060K] 
! 
      IF UP THEN GOTO PTSTP 
! 
      $[WP_WP+1]_(((T-<3) AND 7)-<8)+30040K 
! 
PTSTP:DO[WP_WP+1;UP_NOT UP;F_F+1;IFNOT [L_L-1] THEN\
          GO TO PREPR]
! 
! 
PREPR:IF $[P_P-1]=20040K THEN GO TO PREPR  !FIND LAST 
                                           !NON BLANK 
      N_  P-TB+1      !PRINT LENGTH 
! 
      $ST_  $ST +12K  !SET THE STAR SEPERATOR 
! 
WRTIT:WRIT            !TRANSMIT THE LINE
! 
      GOTO NEXTL      !GO DO NEXT LINE
! 
EOF:  WRITF(O.BUF,.E.R.,$BF,-1) !WRITE EOF
      JER.
      RETURN
      END 
! 
! 
SETA:  SUBROUTINE(PRA)DIRECT !STEP P AND SET PRA IN P INDIRECT
      $[P_P+1]_PRA
      RETURN
      END 
! 
! 
WRIT: SUBROUTINE DIRECT!WRITE ON O.BUF BUFFER AT BF IF LP 
                 !OR TB IF NOT LP WITH LENGTH N+LP
                 !IF TTY -LIMIT LENGTH TO 72. 
      IF TTY THEN[IF N>36 THEN N_36]
      WRITF(O.BUF,.E.R.,$(TB-LP),N+LP)
      JER.
      RETURN
      END 
! 
! 
SPACE:SUBROUTINE DIRECT    !SPACE THE LIST DEVICE 
      N_1           !SET LENGTH TO ONE WORD 
      DO[T_$TB;$TB_ 20040K]!SET BLANK IN BUFFER 
      WRIT          !WRITE BLANK LINE 
      $TB_T         !RESTORE OLD CONTENTS 
      RETURN        !RETURN 
      END 
      END 
      END$