SPL,L,O,M,C 
!     NAME:   LI..  
!     SOURCE: 92064-18151 
!     RELOC:  92064-16055 
!     PGMR:   G.A.A.
!     MOD:    G.L.M.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  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) " 92064-16055  REV.1650  760824" 
! 
! 
!     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 PROCEEDED BY THE HEAD: 
! 
!      NAMEL T=XXXXX IS ON PK XXXXX 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 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 
! 
! 
! 
!     DEFINE EXTERNALS
! 
      LET .TTY BE FUNCTION,EXTERNAL 
      LET JER.          BE SUBROUTINE,EXTERNAL,DIRECT 
! 
      LET IDCB1,IDCB2,BUF.,.E.R ,\
          TMP.,N.OPL,D.LB   BE INTEGER,EXTERNAL 
      LET OPEN.,LOCF,WRITF,READF,EXEC,\ 
       DR.RD,     \ 
                CONV.,JER. \
                            BE SUBROUTINE,EXTERNAL
! 
!     DEFINE INTERNAL ROUTINES
! 
      LET SETA,WRIT,SPACE    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)!** 
! 
!     DEFINE BUFFER SET UP
! 
      LET LSTBF(2),LNNO,BLWD,LBF(128) BE INTEGER
LI..: SUBROUTINE(NOC,LIS ,ER) GLOBAL
! 
      OPFL_401K   !SET DEFAULT OPEN  OPTION 
      NUL_0    !PRESET  NULL PRAM FLAG
      TYPF_($([LIS1_@LIS +1]+4) AND 177400K)+40K
      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; RETURN 56
! 
STYP: TYPF_S.BL                       !FOURCE NULL,ATOS 
! 
TYPOK:OPLS_ @TMP.+3              !GET LIST UNIT OP LIST 
! 
      OPEN.(IDCB2,TMP.,$OPLS, 0) !OPEN LIST FILE
! 
      OPEN.(IDCB1,$LIS1,N.OPL,OPFL) !OPEN FILE TO BE LISTED 
! 
      CALL LOCF(IDCB1,.E.R ,LP,LP,LP,NSEC,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(IDCB2,.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);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 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 FACK 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 $(@IDCB1+2)_1 !FOURCE TYPE 6 TO ONE
      RC_1
NEXT: P_BF          !INITILIZE BUFFER POINTER 
      SETA(R.E)      ! SET UP 
      SETA(C.NO)     !   REC# XXXXX 
      SETA(20040K)
      P_P+2 
      CONV.(RC,$P,5)! SET NUMBER
      READF(IDCB1,.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 GO TO EOF       !SOFT EOF? 
      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 [RC_RC+1;GO TO NEXT] !IF NO DATA GET NEXT
      P_[ST_[WP,T_TB]+27]+1   !INITILIZE 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(IDCB2,.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 IDCB2 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(IDCB2,.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$