SPL,L,O,M 
!     NAME:   LI..
!     SOURCE: 92070-18023 
!     RELOC:  92070-16023 
!     PGMR:   G.A.A.
!     MOD:    M.L.K.
! 
!  ***************************************************************
!  * (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..(7) "  92070-1X023  REV.1941  790712"
! 
! 
!     LI.. IS THE RTE FMGR FILE LIST MODULE 
!          IT IS ENTERED ON COMMAND 
! 
!     LI,NAMR,TY,FREC,LREC
!             -- ---- ----
! 
!        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
! 
!         FREC FIRST RECORD TO PRINT
! 
!         LREC LAST RECORD TO PRINT 
! 
! 
!     EACH LISTING WILL BE PROCEEDED BY THE HEAD: 
! 
!      NAMEL T=XXXXX IS ON PK XXXXX USING XXXX BLKS R=XXXX
!              XX:XX AM  MON., XX  DEC., 1978 
! 
! 
! 
! 
! 
!     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 SEPERATED 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 
! 
! 
!  EXTERNAL SUBROUTINES 
      LET CONV.     BE SUBROUTINE,EXTERNAL
      LET DR.RD     BE SUBROUTINE,EXTERNAL
      LET EXEC      BE SUBROUTINE,EXTERNAL
      LET FTIME     BE SUBROUTINE,EXTERNAL
      LET JER.      BE SUBROUTINE,EXTERNAL,DIRECT 
      LET LOCF      BE SUBROUTINE,EXTERNAL
      LET OPEN.     BE SUBROUTINE,EXTERNAL
      LET READF     BE SUBROUTINE,EXTERNAL
      LET WRITF     BE SUBROUTINE,EXTERNAL
!  EXTERNAL FUNCTIONS 
      LET IFTTY     BE FUNCTION,EXTERNAL
!  EXTERNAL VARIBLES
      LET .E.R      BE INTEGER,EXTERNAL 
      LET BUF.      BE INTEGER,EXTERNAL 
      LET D.LB      BE INTEGER,EXTERNAL 
      LET I.BUF     BE INTEGER,EXTERNAL 
      LET N.OPL     BE INTEGER,EXTERNAL 
      LET O.BUF     BE INTEGER,EXTERNAL 
      LET TMP.      BE INTEGER,EXTERNAL 
!  INTERNAL SUBROUTINES 
      LET SETA      BE SUBROUTINE,DIRECT
      LET SPACE     BE SUBROUTINE,DIRECT
      LET WRIT      BE SUBROUTINE,DIRECT
!  INTERNAL 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)!** 
!  INTERNAL BUFFERS 
      LET LSTBF(2)  BE INTEGER
      LET LNNO      BE INTEGER
      LET BLWD      BE INTEGER
      LET LBF(128)  BE INTEGER
! 
! 
LI..: SUBROUTINE(NOC,LIS ,ER) GLOBAL
! 
      IFNOT NOC  THEN[ ER_ 50 ;RETURN]           !NO PARMS, EXIT
      OPFL_411K                                  !SET DFLT OPEN OPTION
      NUL_0                                      !PRESET NULL PRAM FLAG 
      LR_ $([FR_[TYPF_[LIS1_ @LIS+1]+4]+4]+4)    !
      TYPF_($TYPF AND 177400K)+40K
      IF [FR_$FR]  THEN[                         \SET FIRST AND LAST REC
         IFNOT LR  THEN LR_ FR]                  !DEFAULTS
      IF TYPF=A.BL  THEN GOTO STYP               !CHECK FOR 
      IF TYPF=40K THEN[NUL_1;GO TO STYP]         !LEGAL 
      IF TYPF=D.BL THEN GOTO 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, RETURN 56 
! 
STYP: TYPF_S.BL                                  !FORCE NULL,ATOS 
TYPOK:OPLS_ @TMP.+3                              !GET LIST UNIT OP LIST 
      OPEN.(I.BUF,TMP.,$OPLS, 0)                 !OPEN LIST FILE
      OPEN.(O.BUF,$LIS1,N.OPL,OPFL)              !OPEN FILE TO BE LISTED
! 
      LOCF(O.BUF,.E.R ,LP,LP,LP,NSEC,FLU,FTYP,RECS) 
      IFNOT NUL  THEN GOTO OK                    !IF NULL, CHOSE RITE OPTION
      IFNOT FTYP THEN GOTO OK                    !TYPE ZERO DFLT IS ASC 
      IF FTYP=3  THEN GOTO OK                    !SAME FOR TYPE 3 
      IF FTYP=4  THEN GOTO OK                    !SAME FOR TYPE 4 
CTYP: TYPF_B.BL                                  !ELSE USE BINARY FORMAT
! 
OK:   LOCF(I.BUF,.E.R ,LP,LP,LP,LP,LLU)          !GET LIST LU 
      EXEC(13,LLU,DVT6)                          !GET LIST LU TYPE CODE 
      P36_[P3_@LIS +4]+33                        !SET UP LIST ADDRESSES 
      LP_1                                       !SET LINE PRINTER FLAG 
      IF (DVT6 AND 37400K)<5000K THEN LP_0
      TTY_IFTTY(LLU)                             !INTERACTIVE DEVICE? 
      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);SETA(R.BL);DR.RD(1,-FLU,\ 
                    0);T_$$@D.LB;N_5],\ 
              ELSE[SETA(BL.L);SETA(U.BL);T_FLU;N_2] 
      P_P + N/2 
      CONV.(T,$P,N) 
      IFNOT FTYP THEN[N_13;GO TO WRHD]
      SETA(BL.U)                                 !SET USING 
      SETA(S.I )
      SETA(N.G )
      P_P+3 
! 
      CONV.(NSEC/2,$P,5)
! 
      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 WORD
      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
! 
!     WRITE OUT DATE AND TIME 
! 
      P_ BF                                      !RESET BUFFER POINTER
      FOR I_ 1 TO 4  DO[ SETA(20040K)]           !SPACE OVER
      FTIME($[P_ P+1])                           !GET DATE AND TIME 
      N_ 19                                      !SET LINE LENGTH 
      WRIT                                       !WRITE OUT LINE
! 
      IF TYPF=D.BL THEN GOTO EOF                 !DONE IF HEAD ONLY 
      SPACE                                      !SPACE A LINE
      IF FTYP=6 THEN $(@O.BUF+2)_1               !FORCE TYPE 6 TO 1 
      RC_1
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
      READF(O.BUF,.E.R ,LBF,128,L)               !READ RECORD 
      IF .E.R = -12  THEN GO TO EOF              !IF EOF, GO EXIT 
      JER.                                       !CHECK FOR ERRORS
      IF L <0 THEN GOTO EOF                      !SOFT EOF? 
      IF RC < FR  THEN GOTO NEXTR                !SKIP TO FIRST 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:      RC_ RC+1;                            \INCREMENT REC COUNT 
            IF LR  THEN[ IF RC > LR  THEN GOTO EOF]; \END OF RANGE? 
            GOTO NEXT]                           !DO NEXT 
      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 SEPARATOR
! 
WRTIT:WRIT                                       !TRANSMIT THE LINE 
! 
      GOTO NEXTL                                 !GO DO NEXT LINE 
! 
EOF:  WRITF(I.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 I.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(I.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          !WRIT BLANK LINE
      $TB_T         !RESTORE OLD CONTENTS 
      RETURN        !RETURN 
      END 
      END 
      END$
                                                                                                                                                                                                                                    